diff options
| author | Joey Hess <joeyh@joeyh.name> | 2020-01-02 12:34:10 -0400 |
|---|---|---|
| committer | Joey Hess <joeyh@joeyh.name> | 2020-01-02 12:42:57 -0400 |
| commit | 9df8a6eb9405dde4464d27133c04f5ee539a85de (patch) | |
| tree | 8a7ac5f52be8679f8a2525515a0b2c1b715c99ad | |
| parent | 16022a8b98f4bc134542e78a42538364d2f97d92 (diff) | |
| download | git-repair-9df8a6eb9405dde4464d27133c04f5ee539a85de.tar.gz | |
merge from git-annex and relicense accordingly
Merge git library and utility from git-annex. The former is now relicensed
AGPL, so git-repair as a whole becomes AGPL.
For simplicity, I am relicensing the remainder of the code in git-repair
AGPL as well, per the header changes in this commit. While that code is
also technically available under the GPL license, as it's been released
under that license before, changes going forward will be only released by
me under the AGPL.
68 files changed, 2191 insertions, 1712 deletions
diff --git a/Build/Configure.hs b/Build/Configure.hs index dc15141..1a3527f 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -5,8 +5,9 @@ module Build.Configure where import System.Environment -import Control.Applicative import Control.Monad.IfElse +import Control.Applicative +import Prelude import Build.TestConfig import Build.Version @@ -25,7 +26,6 @@ getGitVersion = Config "gitversion" . StringConfig . show run :: [TestCase] -> IO () run ts = do - args <- getArgs config <- runTests ts writeSysConfig config whenM (isReleaseBuild) $ diff --git a/BuildInfo.hs b/BuildInfo.hs index 812402c..e54bdca 100644 --- a/BuildInfo.hs +++ b/BuildInfo.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -1,8 +1,12 @@ -git-repair (1.20170627) UNRELEASED; urgency=medium +git-repair (1.20200102) unstable; urgency=medium + * Relicensed AGPL. * Merge from git-annex. + * Removed the network-uri build flag. + * Increased required version of several dependencies. + * Added dependencies on deepseq, attoparsec and filepath-bytestring. - -- Joey Hess <id@joeyh.name> Thu, 14 Dec 2017 12:55:44 -0400 + -- Joey Hess <id@joeyh.name> Thu, 02 Jan 2020 12:39:13 -0400 git-repair (1.20170626) unstable; urgency=medium diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 0000000..cd51274 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,695 @@ +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Source: native package + +Files: * +Copyright: © 2013-2019 Joey Hess <joey@kitenet.net> +License: AGPL-3+ + +Files: Utility/* +Copyright: 2012-2019 Joey Hess <joey@kitenet.net> +License: BSD-2-clause + +License: BSD-2-clause + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + . + THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +License: AGPL-3+ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + . + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + . + Preamble + . + The GNU 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. + . + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + . + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU 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 <http://www.gnu.org/licenses/>. + . + 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 + <http://www.gnu.org/licenses/>. @@ -18,6 +18,7 @@ import System.IO as X hiding (FilePath) import System.Posix.IO as X hiding (createPipe) #endif import System.Exit as X +import System.PosixCompat.Files as X import Utility.Misc as X import Utility.Exception as X @@ -28,8 +29,8 @@ import Utility.Directory as X import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X -import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X import Utility.Split as X +import Utility.FileSystemEncoding as X import Utility.PartialPrelude as X @@ -1,674 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU General Public License is a free, copyleft license for -software and other kinds of works. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -the GNU General Public License is intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. We, the Free Software Foundation, use the -GNU General Public License for most of our software; it applies also to -any other work released this way by its authors. You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - To protect your rights, we need to prevent others from denying you -these rights or asking you to surrender the rights. Therefore, you have -certain responsibilities if you distribute copies of the software, or if -you modify it: responsibilities to respect the freedom of others. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must pass on to the recipients the same -freedoms that you received. You must make sure that they, too, receive -or can get the source code. And you must show them these terms so they -know their rights. - - Developers that use the GNU GPL protect your rights with two steps: -(1) assert copyright on the software, and (2) offer you this License -giving you legal permission to copy, distribute and/or modify it. - - For the developers' and authors' protection, the GPL clearly explains -that there is no warranty for this free software. For both users' and -authors' sake, the GPL requires that modified versions be marked as -changed, so that their problems will not be attributed erroneously to -authors of previous versions. - - Some devices are designed to deny users access to install or run -modified versions of the software inside them, although the manufacturer -can do so. This is fundamentally incompatible with the aim of -protecting users' freedom to change the software. The systematic -pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we -have designed this version of the GPL to prohibit the practice for those -products. If such problems arise substantially in other domains, we -stand ready to extend this provision to those domains in future versions -of the GPL, as needed to protect the freedom of users. - - Finally, every program is threatened constantly by software patents. -States should not allow patents to restrict development and use of -software on general-purpose computers, but in those that do, we wish to -avoid the special danger that patents applied to a free program could -make it effectively proprietary. To prevent this, the GPL assures that -patents cannot be used to render the program non-free. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Use with the GNU Affero General Public License. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU Affero General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the special requirements of the GNU Affero General Public License, -section 13, concerning interaction through a network will apply to the -combination as such. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> - Copyright (C) <year> <name of author> - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see <http://www.gnu.org/licenses/>. - -Also add information on how to contact you by electronic and paper mail. - - If the program does terminal interaction, make it output a short -notice like this when it starts in an interactive mode: - - <program> Copyright (C) <year> <name of author> - This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, your program's commands -might be different; for a GUI interface, you would use an "about box". - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU GPL, see -<http://www.gnu.org/licenses/>. - - The GNU General Public License does not permit incorporating your program -into proprietary programs. If your program is a subroutine library, you -may consider it more useful to permit linking proprietary applications with -the library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. But first, please read -<http://www.gnu.org/philosophy/why-not-lgpl.html>. @@ -5,7 +5,7 @@ - - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -51,35 +51,35 @@ import Utility.FileMode repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url -repoDescribe Repo { location = Local { worktree = Just dir } } = dir -repoDescribe Repo { location = Local { gitdir = dir } } = dir -repoDescribe Repo { location = LocalUnknown dir } = dir +repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir +repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir +repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir repoDescribe Repo { location = Unknown } = "UNKNOWN" {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url -repoLocation Repo { location = Local { worktree = Just dir } } = dir -repoLocation Repo { location = Local { gitdir = dir } } = dir -repoLocation Repo { location = LocalUnknown dir } = dir +repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir +repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir +repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir repoLocation Repo { location = Unknown } = error "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - it's the gitdir, and for URL repositories, is the path on the remote - host. -} -repoPath :: Repo -> FilePath -repoPath Repo { location = Url u } = unEscapeString $ uriPath u +repoPath :: Repo -> RawFilePath +repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = error "unknown repoPath" -repoWorkTree :: Repo -> Maybe FilePath +repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d repoWorkTree _ = Nothing {- Path to a local repository's .git directory. -} -localGitDir :: Repo -> FilePath +localGitDir :: Repo -> RawFilePath localGitDir Repo { location = Local { gitdir = d } } = d localGitDir _ = error "unknown localGitDir" @@ -132,16 +132,17 @@ assertLocal repo action attributes :: Repo -> FilePath attributes repo | repoIsLocalBare repo = attributesLocal repo - | otherwise = repoPath repo </> ".gitattributes" + | otherwise = fromRawFilePath (repoPath repo) </> ".gitattributes" attributesLocal :: Repo -> FilePath -attributesLocal repo = localGitDir repo </> "info" </> "attributes" +attributesLocal repo = fromRawFilePath (localGitDir repo) + </> "info" </> "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} hookPath :: String -> Repo -> IO (Maybe FilePath) hookPath script repo = do - let hook = localGitDir repo </> "hooks" </> script + let hook = fromRawFilePath (localGitDir repo) </> "hooks" </> script ifM (catchBoolIO $ isexecutable hook) ( return $ Just hook , return Nothing ) where @@ -157,22 +158,22 @@ relPath = adjustPath torel where torel p = do p' <- relPathCwdToFile p - if null p' - then return "." - else return p' + return $ if null p' then "." else p' {- Adusts the path to a local Repo using the provided function. -} adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do - d' <- f d - w' <- maybe (pure Nothing) (Just <$$> f) w + d' <- f' d + w' <- maybe (pure Nothing) (Just <$$> f') w return $ r { location = l { gitdir = d' , worktree = w' } } + where + f' v = toRawFilePath <$> f (fromRawFilePath v) adjustPath f r@(Repo { location = LocalUnknown d }) = do - d' <- f d + d' <- toRawFilePath <$> f (fromRawFilePath d) return $ r { location = LocalUnknown d' } adjustPath _ r = pure r diff --git a/Git/Branch.hs b/Git/Branch.hs index 875f20f..699fbf5 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -2,10 +2,11 @@ - - Copyright 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Branch where @@ -15,13 +16,14 @@ import Git.Sha import Git.Command import qualified Git.Config import qualified Git.Ref -import qualified Git.BuildVersion + +import qualified Data.ByteString as B {- The currently checked out branch. - - In a just initialized git repo before the first commit, - symbolic-ref will show the master branch, even though that - - branch is not created yet. So, this also looks at show-ref HEAD + - branch is not created yet. So, this also looks at show-ref - to double-check. -} current :: Repo -> IO (Maybe Branch) @@ -30,19 +32,19 @@ current r = do case v of Nothing -> return Nothing Just branch -> - ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) + ifM (B.null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) ( return Nothing , return v ) {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch) -currentUnsafe r = parse . firstLine +currentUnsafe r = parse . firstLine' <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where - parse l - | null l = Nothing - | otherwise = Just $ Git.Ref l + parse b + | B.null b = Nothing + | otherwise = Just $ Git.Ref $ decodeBS b {- Checks if the second branch has any commits not present on the first - branch. -} @@ -54,7 +56,8 @@ changed origbranch newbranch repo where changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String -changed' origbranch newbranch extraps repo = pipeReadStrict ps repo +changed' origbranch newbranch extraps repo = + decodeBS <$> pipeReadStrict ps repo where ps = [ Param "log" @@ -73,7 +76,7 @@ changedCommits origbranch newbranch extraps repo = - - This requires there to be a path from the old to the new. -} fastForwardable :: Ref -> Ref -> Repo -> IO Bool -fastForwardable old new repo = not . null <$> +fastForwardable old new repo = not . B.null <$> pipeReadStrict [ Param "log" , Param $ fromRef old ++ ".." ++ fromRef new @@ -125,8 +128,7 @@ data CommitMode = ManualCommit | AutomaticCommit {- Prevent signing automatic commits. -} applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] applyCommitMode commitmode ps - | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = - Param "--no-gpg-sign" : ps + | commitmode == AutomaticCommit = Param "--no-gpg-sign" : ps | otherwise = ps {- Some versions of git commit-tree honor commit.gpgsign themselves, @@ -134,8 +136,8 @@ applyCommitMode commitmode ps applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam] applyCommitModeForCommitTree commitmode ps r | commitmode == ManualCommit = - case (Git.Config.getMaybe "commit.gpgsign" r) of - Just s | Git.Config.isTrue s == Just True -> + case Git.Config.getMaybe "commit.gpgsign" r of + Just s | Git.Config.isTrueFalse' s == Just True -> Param "-S":ps _ -> ps' | otherwise = ps' @@ -162,7 +164,7 @@ commitCommand' runner commitmode ps = runner $ commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do tree <- getSha "write-tree" $ - pipeReadStrict [Param "write-tree"] repo + decodeBS' <$> pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs index 7d1c53a..f94a892 100644 --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.BuildVersion where diff --git a/Git/CatFile.hs b/Git/CatFile.hs index ba68c4e..6402001 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,8 +1,8 @@ {- git cat-file interface - - - Copyright 2011-2016 Joey Hess <id@joeyh.name> + - Copyright 2011-2019 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CatFile ( @@ -28,20 +28,23 @@ import Data.String import Data.Char import Numeric import System.Posix.Types +import Text.Read import Common import Git import Git.Sha +import qualified Git.Ref import Git.Command import Git.Types import Git.FilePath +import Git.HashObject import qualified Utility.CoProcess as CoProcess -import Utility.FileSystemEncoding import Utility.Tuple data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle , checkFileProcess :: CoProcess.CoProcessHandle + , gitRepo :: Repo } catFileStart :: Repo -> IO CatFileHandle @@ -51,6 +54,7 @@ catFileStart' :: Bool -> Repo -> IO CatFileHandle catFileStart' restartable repo = CatFileHandle <$> startp "--batch" <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + <*> pure repo where startp p = gitCoProcessStart restartable [ Param "cat-file" @@ -63,13 +67,13 @@ catFileStop h = do CoProcess.stop (checkFileProcess h) {- Reads a file from a specified branch. -} -catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString +catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $ - fromRef branch ++ ":" ++ toInternalGitPath file + fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) -catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $ - fromRef branch ++ ":" ++ toInternalGitPath file + fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -77,7 +81,7 @@ catObject :: CatFileHandle -> Ref -> IO L.ByteString catObject h object = maybe L.empty fst3 <$> catObjectDetails h object catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) -catObjectDetails h object = query (catFileProcess h) object $ \from -> do +catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do header <- hGetLine from case parseResp object header of Just (ParsedResp sha size objtype) -> do @@ -91,23 +95,53 @@ catObjectDetails h object = query (catFileProcess h) object $ \from -> do c <- hGetChar from when (c /= expected) $ error $ "missing " ++ (show expected) ++ " from git cat-file" + + -- Slow fallback path for filenames containing newlines. + newlinefallback = queryObjectType object (gitRepo h) >>= \case + Nothing -> return Nothing + Just objtype -> queryContent object (gitRepo h) >>= \case + Nothing -> return Nothing + Just content -> do + -- only the --batch interface allows getting + -- the sha, so have to re-hash the object + sha <- hashObject' objtype + (flip L.hPut content) + (gitRepo h) + return (Just (content, sha, objtype)) {- Gets the size and type of an object, without reading its content. -} -catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType)) -catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do +catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) +catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do resp <- hGetLine from case parseResp object resp of - Just (ParsedResp _ size objtype) -> - return $ Just (size, objtype) + Just (ParsedResp sha size objtype) -> + return $ Just (sha, size, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) + where + -- Slow fallback path for filenames containing newlines. + newlinefallback = do + sha <- Git.Ref.sha object (gitRepo h) + sz <- querySize object (gitRepo h) + objtype <- queryObjectType object (gitRepo h) + return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha Integer ObjectType | DNE +data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE -query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a -query hdl object receive = CoProcess.query hdl send receive +query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a +query hdl object newlinefallback receive + -- git cat-file --batch uses a line based protocol, so when the + -- filename itself contains a newline, have to fall back to another + -- method of getting the information. + | '\n' `elem` s = newlinefallback + -- git strips carriage return from the end of a line, out of some + -- misplaced desire to support windows, so also use the newline + -- fallback for those. + | "\r" `isSuffixOf` s = newlinefallback + | otherwise = CoProcess.query hdl send receive where - send to = hPutStrLn to (fromRef object) + send to = hPutStrLn to s + s = fromRef object parseResp :: Ref -> String -> Maybe ParsedResp parseResp object l @@ -116,13 +150,50 @@ parseResp object l | otherwise = case words l of [sha, objtype, size] | length sha == shaSize -> - case (readObjectType objtype, reads size) of + case (readObjectType (encodeBS objtype), reads size) of (Just t, [(bytes, "")]) -> Just $ ParsedResp (Ref sha) bytes t _ -> Nothing | otherwise -> Nothing _ -> Nothing +querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a) +querySingle o r repo reader = assertLocal repo $ + -- In non-batch mode, git cat-file warns on stderr when + -- asked for an object that does not exist. + -- Squelch that warning to behave the same as batch mode. + withNullHandle $ \nullh -> do + let p = gitCreateProcess + [ Param "cat-file" + , o + , Param (fromRef r) + ] repo + let p' = p + { std_err = UseHandle nullh + , std_in = Inherit + , std_out = CreatePipe + } + pid <- createProcess p' + let h = stdoutHandle pid + output <- reader h + hClose h + ifM (checkSuccessProcess (processHandle pid)) + ( return (Just output) + , return Nothing + ) + +querySize :: Ref -> Repo -> IO (Maybe FileSize) +querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n')) + <$> querySingle (Param "-s") r repo hGetContentsStrict + +queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType) +queryObjectType r repo = maybe Nothing (readObjectType . encodeBS . takeWhile (/= '\n')) + <$> querySingle (Param "-t") r repo hGetContentsStrict + +queryContent :: Ref -> Repo -> IO (Maybe L.ByteString) +queryContent r repo = fmap (\b -> L.fromChunks [b]) + <$> querySingle (Param "-p") r repo S.hGetContents + {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] catTree h treeref = go <$> catObjectDetails h treeref @@ -141,7 +212,7 @@ catTree h treeref = go <$> catObjectDetails h treeref dropsha = L.drop 21 parsemodefile b = - let (modestr, file) = separate (== ' ') (decodeBS b) + let (modestr, file) = separate (== ' ') (decodeBL b) in (file, readmode modestr) readmode = fromMaybe 0 . fmap fst . headMaybe . readOct diff --git a/Git/Command.hs b/Git/Command.hs index f40dfab..eb20af2 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -14,6 +14,9 @@ import Git import Git.Types import qualified Utility.CoProcess as CoProcess +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S + {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params r@(Repo { location = l@(Local { } ) }) = @@ -21,10 +24,10 @@ gitCommandLine params r@(Repo { location = l@(Local { } ) }) = where setdir | gitEnvOverridesGitDir r = [] - | otherwise = [Param $ "--git-dir=" ++ gitdir l] + | otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)] settree = case worktree l of Nothing -> [] - Just t -> [Param $ "--work-tree=" ++ t] + Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t] gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} @@ -47,13 +50,13 @@ runQuiet params repo = withQuietOutput createProcessSuccess $ {- Runs a git command and returns its output, lazily. - - Also returns an action that should be used when the output is all - - read (or no more is needed), that will wait on the command, and + - read, that will wait on the command, and - return True if it succeeded. Failure to wait will result in zombies. -} -pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) +pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool) pipeReadLazy params repo = assertLocal repo $ do (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } - c <- hGetContents h + c <- L.hGetContents h return (c, checkSuccessProcess pid) where p = gitCreateProcess params repo @@ -62,10 +65,14 @@ pipeReadLazy params repo = assertLocal repo $ do - - Nonzero exit status is ignored. -} -pipeReadStrict :: [CommandParam] -> Repo -> IO String -pipeReadStrict params repo = assertLocal repo $ +pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString +pipeReadStrict = pipeReadStrict' S.hGetContents + +{- The reader action must be strict. -} +pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a +pipeReadStrict' reader params repo = assertLocal repo $ withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do - output <- hGetContentsStrict h + output <- reader h hClose h return output where @@ -83,28 +90,36 @@ pipeWriteRead params writer repo = assertLocal repo $ {- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () -pipeWrite params repo = withHandle StdinHandle createProcessSuccess $ - gitCreateProcess params repo +pipeWrite params repo = assertLocal repo $ + withHandle StdinHandle createProcessSuccess $ + gitCreateProcess params repo {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} -pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool) +pipeNullSplit :: [CommandParam] -> Repo -> IO ([L.ByteString], IO Bool) pipeNullSplit params repo = do (s, cleanup) <- pipeReadLazy params repo - return (filter (not . null) $ splitc sep s, cleanup) - where - sep = '\0' + return (filter (not . L.null) $ L.split 0 s, cleanup) -pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] +{- Reads lazily, but copies each part to a strict ByteString for + - convenience. + -} +pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool) +pipeNullSplit' params repo = do + (s, cleanup) <- pipeNullSplit params repo + return (map L.toStrict s, cleanup) + +pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [S.ByteString] pipeNullSplitStrict params repo = do s <- pipeReadStrict params repo - return $ filter (not . null) $ splitc sep s - where - sep = '\0' + return $ filter (not . S.null) $ S.split 0 s -pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] +pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString] pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo +pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString] +pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo + {- Doesn't run the cleanup action. A zombie results. -} leaveZombie :: (a, IO Bool) -> a leaveZombie = fst diff --git a/Git/Config.hs b/Git/Config.hs index 9b4c342..4b60664 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,32 +1,37 @@ {- git repository configuration handling - - - Copyright 2010-2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2019 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Config where import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Data.Char +import qualified System.FilePath.ByteString as P import Common import Git import Git.Types -import qualified Git.Construct import qualified Git.Command +import qualified Git.Construct import Utility.UserInfo -{- Returns a single git config setting, or a default value if not set. -} -get :: String -> String -> Repo -> String -get key defaultValue repo = M.findWithDefault defaultValue key (config repo) +{- Returns a single git config setting, or a fallback value if not set. -} +get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue +get key fallback repo = M.findWithDefault fallback key (config repo) -{- Returns a list with each line of a multiline config setting. -} -getList :: String -> Repo -> [String] +{- Returns a list of values. -} +getList :: ConfigKey -> Repo -> [ConfigValue] getList key repo = M.findWithDefault [] key (fullconfig repo) {- Returns a single git config setting, if set. -} -getMaybe :: String -> Repo -> Maybe String +getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue getMaybe key repo = M.lookup key (config repo) {- Runs git config and populates a repo with its config. @@ -57,7 +62,7 @@ read' repo = go repo where params = ["config", "--null", "--list"] p = (proc "git" params) - { cwd = Just d + { cwd = Just (fromRawFilePath d) , env = gitEnv repo } @@ -79,22 +84,28 @@ global = do {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo hRead repo h = do - val <- hGetContentsStrict h + val <- S.hGetContents h store val repo {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -} -store :: String -> Repo -> IO Repo +store :: S.ByteString -> Repo -> IO Repo store s repo = do let c = parse s - repo' <- updateLocation $ repo + updateLocation $ repo { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo) } - rs <- Git.Construct.fromRemotes repo' - return $ repo' { remotes = rs } + +{- Stores a single config setting in a Repo, returning the new version of + - the Repo. Config settings can be updated incrementally. -} +store' :: ConfigKey -> ConfigValue -> Repo -> Repo +store' k v repo = repo + { config = M.singleton k v `M.union` config repo + , fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo) + } {- Updates the location of a repo, based on its configuration. - @@ -104,13 +115,13 @@ store s repo = do -} updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d }) - | isBare r = ifM (doesDirectoryExist dotgit) + | isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit)) ( updateLocation' r $ Local dotgit Nothing , updateLocation' r $ Local d Nothing ) | otherwise = updateLocation' r $ Local dotgit (Just d) where - dotgit = (d </> ".git") + dotgit = d P.</> ".git" updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -118,52 +129,66 @@ updateLocation' :: Repo -> RepoLocation -> IO Repo updateLocation' r l = do l' <- case getMaybe "core.worktree" r of Nothing -> return l - Just d -> do + Just (ConfigValue d) -> do {- core.worktree is relative to the gitdir -} - top <- absPath $ gitdir l - return $ l { worktree = Just $ absPathFrom top d } + top <- absPath $ fromRawFilePath (gitdir l) + let p = absPathFrom top (fromRawFilePath d) + return $ l { worktree = Just (toRawFilePath p) } return $ r { location = l' } {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: String -> M.Map String [String] -parse [] = M.empty +parse :: S.ByteString -> M.Map ConfigKey [ConfigValue] parse s - -- --list output will have an = in the first line - | all ('=' `elem`) (take 1 ls) = sep '=' ls + | S.null s = M.empty + -- --list output will have a '=' in the first line + -- (The first line of --null --list output is the name of a key, + -- which is assumed to never contain '='.) + | S.elem eq firstline = sep eq $ S.split nl s -- --null --list output separates keys from values with newlines - | otherwise = sep '\n' $ splitc '\0' s + | otherwise = sep nl $ S.split 0 s where - ls = lines s - sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . - map (separate (== c)) + nl = fromIntegral (ord '\n') + eq = fromIntegral (ord '=') + firstline = S.takeWhile (/= nl) s + + sep c = M.fromListWith (++) + . map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) + . map (S.break (== c)) -{- Checks if a string from git config is a true value. -} -isTrue :: String -> Maybe Bool -isTrue s +{- Checks if a string from git config is a true/false value. -} +isTrueFalse :: String -> Maybe Bool +isTrueFalse = isTrueFalse' . ConfigValue . encodeBS' + +isTrueFalse' :: ConfigValue -> Maybe Bool +isTrueFalse' (ConfigValue s) | s' == "true" = Just True | s' == "false" = Just False | otherwise = Nothing where - s' = map toLower s + s' = S8.map toLower s boolConfig :: Bool -> String boolConfig True = "true" boolConfig False = "false" +boolConfig' :: Bool -> S.ByteString +boolConfig' True = "true" +boolConfig' False = "false" + isBare :: Repo -> Bool -isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r +isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r -coreBare :: String +coreBare :: ConfigKey coreBare = "core.bare" {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - output of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) +fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString)) fromPipe r cmd params = try $ withHandle StdoutHandle createProcessSuccess p $ \h -> do - val <- hGetContentsStrict h + val <- S.hGetContents h r' <- store val r return (r', val) where @@ -171,7 +196,7 @@ fromPipe r cmd params = try $ {- Reads git config from a specified file and returns the repo populated - with the configuration. -} -fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String)) +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" @@ -181,13 +206,13 @@ fromFile r f = fromPipe r "git" {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} -changeFile :: FilePath -> String -> String -> IO Bool -changeFile f k v = boolSystem "git" +changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool +changeFile f (ConfigKey k) v = boolSystem "git" [ Param "config" , Param "--file" , File f - , Param k - , Param v + , Param (decodeBS' k) + , Param (decodeBS' v) ] {- Unsets a git config setting, in both the git repo, @@ -196,10 +221,10 @@ changeFile f k v = boolSystem "git" - If unsetting the config fails, including in a read-only repo, or - when the config is not set, returns Nothing. -} -unset :: String -> Repo -> IO (Maybe Repo) -unset k r = ifM (Git.Command.runBool ps r) - ( return $ Just $ r { config = M.delete k (config r) } +unset :: ConfigKey -> Repo -> IO (Maybe Repo) +unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r) + ( return $ Just $ r { config = M.delete ck (config r) } , return Nothing ) where - ps = [Param "config", Param "--unset-all", Param k] + ps = [Param "config", Param "--unset-all", Param (decodeBS' k)] diff --git a/Git/Construct.hs b/Git/Construct.hs index 4ad74fd..5b656eb 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -58,11 +58,11 @@ fromPath dir = fromAbsPath =<< absPath dir - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir - | absoluteGitPath dir = hunt + | absoluteGitPath (encodeBS dir) = hunt | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where - ret = pure . newFrom . LocalUnknown + ret = pure . newFrom . LocalUnknown . toRawFilePath canondir = dropTrailingPathSeparator dir {- When dir == "foo/.git", git looks for "foo/.git/.git", - and failing that, uses "foo" as the repository. -} @@ -117,7 +117,7 @@ localToUrl reference r [ Url.scheme reference , "//" , auth - , repoPath r + , fromRawFilePath (repoPath r) ] in r { location = Url $ fromJust $ parseURI absurl } @@ -127,9 +127,8 @@ fromRemotes repo = mapM construct remotepairs where filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) - remotepairs = filterkeys isremote - isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k - construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + remotepairs = filterkeys isRemoteKey + construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo) {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -139,11 +138,8 @@ remoteNamed n constructor = do {- Sets the name of a remote based on the git config key, such as - "remote.foo.url". -} -remoteNamedFromKey :: String -> IO Repo -> IO Repo -remoteNamedFromKey k = remoteNamed basename - where - basename = intercalate "." $ - reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k +remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo +remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} @@ -158,7 +154,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ repoPath repo </> dir' + fromPath $ fromRawFilePath (repoPath repo) </> dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. @@ -208,20 +204,29 @@ checkForRepo dir = where check test cont = maybe cont (return . Just) =<< test checkdir c = ifM c - ( return $ Just $ LocalUnknown dir + ( return $ Just $ LocalUnknown $ toRawFilePath dir , return Nothing ) - isRepo = checkdir $ gitSignature $ ".git" </> "config" + isRepo = checkdir $ + gitSignature (".git" </> "config") + <||> + -- A git-worktree lacks .git/config, but has .git/commondir. + -- (Normally the .git is a file, not a symlink, but it can + -- be converted to a symlink and git will still work; + -- this handles that case.) + gitSignature (".git" </> "gitdir") isBareRepo = checkdir $ gitSignature "config" <&&> doesDirectoryExist (dir </> "objects") gitDirFile = do + -- git-submodule, git-worktree, and --separate-git-dir + -- make .git be a file pointing to the real git directory. c <- firstLine <$> catchDefaultIO "" (readFile $ dir </> ".git") return $ if gitdirprefix `isPrefixOf` c then Just $ Local - { gitdir = absPathFrom dir $ + { gitdir = toRawFilePath $ absPathFrom dir $ drop (length gitdirprefix) c - , worktree = Just dir + , worktree = Just (toRawFilePath dir) } else Nothing where @@ -233,7 +238,6 @@ newFrom l = Repo { location = l , config = M.empty , fullconfig = M.empty - , remotes = [] , remoteName = Nothing , gitEnv = Nothing , gitEnvOverridesGitDir = False diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 69a679e..054a81e 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CurrentRepo where @@ -12,6 +12,7 @@ import Git.Types import Git.Construct import qualified Git.Config import Utility.Env +import Utility.Env.Set {- Gets the current git repository. - @@ -24,12 +25,20 @@ import Utility.Env - directory if necessary to ensure it is within the repository's work - tree. While not needed for git commands, this is useful for anything - else that looks for files in the worktree. + - + - Also works around a git bug when running some hooks. It + - runs the hooks in the top of the repository, but if GIT_WORK_TREE + - was relative (but not "."), it then points to the wrong directory. + - In this situation GIT_PREFIX contains the directory that + - GIT_WORK_TREE is relative to. -} get :: IO Repo get = do - gd <- pathenv "GIT_DIR" + gd <- getpathenv "GIT_DIR" r <- configure gd =<< fromCwd - wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE" + prefix <- getpathenv "GIT_PREFIX" + wt <- maybe (fromRawFilePath <$> worktree (location r)) Just + <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of Nothing -> return r Just d -> do @@ -38,22 +47,39 @@ get = do setCurrentDirectory d return $ addworktree wt r where - pathenv s = do + getpathenv s = do v <- getEnv s case v of Just d -> do unsetEnv s - Just <$> absPath d + return (Just d) + Nothing -> return Nothing + + getpathenvprefix s (Just prefix) | not (null prefix) = + getpathenv s >>= \case Nothing -> return Nothing + Just d + | d == "." -> return (Just d) + | otherwise -> Just <$> absPath (prefix </> d) + getpathenvprefix s _ = getpathenv s configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do absd <- absPath d curr <- getCurrentDirectory - Git.Config.read $ newFrom $ - Local { gitdir = absd, worktree = Just curr } + r <- Git.Config.read $ newFrom $ + Local + { gitdir = toRawFilePath absd + , worktree = Just (toRawFilePath curr) + } + return $ if Git.Config.isBare r + then r { location = (location r) { worktree = Nothing } } + else r + configure Nothing Nothing = giveup "Not in a git repository." - addworktree w r = changelocation r $ - Local { gitdir = gitdir (location r), worktree = w } + addworktree w r = changelocation r $ Local + { gitdir = gitdir (location r) + , worktree = fmap toRawFilePath w + } changelocation r l = r { location = l } diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs index e923796..3dc8529 100644 --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -4,7 +4,7 @@ - - Copyright 2013, 2014 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Destroyer ( @@ -83,7 +83,7 @@ generateDamage = sample' (arbitrary :: Gen Damage) applyDamage :: [Damage] -> Repo -> IO () applyDamage ds r = do contents <- sort . filter (not . skipped) - <$> dirContentsRecursive (localGitDir r) + <$> dirContentsRecursive (fromRawFilePath (localGitDir r)) forM_ ds $ \d -> do let withfile s a = do let f = selectFile contents s diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs index 859f590..ffda2e8 100644 --- a/Git/DiffTreeItem.hs +++ b/Git/DiffTreeItem.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.DiffTreeItem ( diff --git a/Git/FilePath.hs b/Git/FilePath.hs index ffa3331..66a0159 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,12 +5,14 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012-2013 Joey Hess <id@joeyh.name> + - Copyright 2012-2019 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Git.FilePath ( TopFilePath, @@ -29,30 +31,39 @@ module Git.FilePath ( import Common import Git -import qualified System.FilePath.Posix +import qualified System.FilePath.ByteString as P +import qualified System.FilePath.Posix.ByteString +import GHC.Generics +import Control.DeepSeq +import qualified Data.ByteString as S -{- A FilePath, relative to the top of the git repository. -} -newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } - deriving (Show, Eq, Ord) +{- A RawFilePath, relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath } + deriving (Show, Eq, Ord, Generic) + +instance NFData TopFilePath {- A file in a branch or other treeish. -} data BranchFilePath = BranchFilePath Ref TopFilePath + deriving (Show, Eq, Ord) {- Git uses the branch:file form to refer to a BranchFilePath -} -descBranchFilePath :: BranchFilePath -> String -descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f +descBranchFilePath :: BranchFilePath -> S.ByteString +descBranchFilePath (BranchFilePath b f) = + encodeBS' (fromRef b) <> ":" <> getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} -fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath -fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) +fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath +fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} -toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath -toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file +toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath +toTopFilePath file repo = TopFilePath . toRawFilePath + <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file) -{- The input FilePath must already be relative to the top of the git +{- The input RawFilePath must already be relative to the top of the git - repository -} -asTopFilePath :: FilePath -> TopFilePath +asTopFilePath :: RawFilePath -> TopFilePath asTopFilePath file = TopFilePath file {- Git may use a different representation of a path when storing @@ -62,25 +73,25 @@ asTopFilePath file = TopFilePath file - despite Windows using '\'. - -} -type InternalGitPath = String +type InternalGitPath = RawFilePath -toInternalGitPath :: FilePath -> InternalGitPath +toInternalGitPath :: RawFilePath -> InternalGitPath #ifndef mingw32_HOST_OS toInternalGitPath = id #else -toInternalGitPath = replace "\\" "/" +toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS #endif -fromInternalGitPath :: InternalGitPath -> FilePath +fromInternalGitPath :: InternalGitPath -> RawFilePath #ifndef mingw32_HOST_OS fromInternalGitPath = id #else -fromInternalGitPath = replace "/" "\\" +fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS #endif {- isAbsolute on Windows does not think "/foo" or "\foo" is absolute, - so try posix paths. -} -absoluteGitPath :: FilePath -> Bool -absoluteGitPath p = isAbsolute p || - System.FilePath.Posix.isAbsolute (toInternalGitPath p) +absoluteGitPath :: RawFilePath -> Bool +absoluteGitPath p = P.isAbsolute p || + System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p) diff --git a/Git/Filename.hs b/Git/Filename.hs index 355e75f..010e5ba 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -3,7 +3,7 @@ - - Copyright 2010, 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Filename where @@ -12,23 +12,44 @@ import Common import Utility.Format (decode_c, encode_c) import Data.Char +import Data.Word +import qualified Data.ByteString as S -decode :: String -> FilePath -decode [] = [] -decode f@(c:s) - -- encoded strings will be inside double quotes - | c == '"' && end s == ['"'] = decode_c $ beginning s - | otherwise = f +-- encoded filenames will be inside double quotes +decode :: S.ByteString -> RawFilePath +decode b = case S.uncons b of + Nothing -> b + Just (h, t) + | h /= q -> b + | otherwise -> case S.unsnoc t of + Nothing -> b + Just (i, l) + | l /= q -> b + | otherwise -> + encodeBS $ decode_c $ decodeBS i + where + q :: Word8 + q = fromIntegral (ord '"') {- Should not need to use this, except for testing decode. -} -encode :: FilePath -> String -encode s = "\"" ++ encode_c s ++ "\"" +encode :: RawFilePath -> S.ByteString +encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" -{- For quickcheck. - - - - See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for - - why this only tests chars < 256 -} -prop_encode_decode_roundtrip :: String -> Bool -prop_encode_decode_roundtrip s = s' == decode (encode s') +prop_encode_decode_roundtrip :: FilePath -> Bool +prop_encode_decode_roundtrip s = s' == + fromRawFilePath (decode (encode (toRawFilePath s'))) where - s' = filter (\c -> ord c < 256) s + s' = nonul (nohigh s) + -- Encoding and then decoding roundtrips only when + -- the string does not contain high unicode, because eg, + -- both "\12345" and "\227\128\185" are encoded to + -- "\343\200\271". + -- + -- This property papers over the problem, by only + -- testing ascii + nohigh = filter isAscii + -- A String can contain a NUL, but toRawFilePath + -- truncates on the NUL, which is generally fine + -- because unix filenames cannot contain NUL. + -- So the encoding only roundtrips when there is no nul. + nonul = filter (/= '\NUL') diff --git a/Git/Fsck.hs b/Git/Fsck.hs index a716b56..6f33e11 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} @@ -22,10 +22,11 @@ import Git import Git.Command import Git.Sha import Utility.Batch -import qualified Git.Version import qualified Data.Set as S import Control.Concurrent.Async +import qualified Data.Semigroup as Sem +import Prelude data FsckResults = FsckFoundMissing @@ -44,15 +45,21 @@ type MissingObjects = S.Set Sha type Truncated = Bool +appendFsckOutput :: FsckOutput -> FsckOutput -> FsckOutput +appendFsckOutput (FsckOutput s1 t1) (FsckOutput s2 t2) = + FsckOutput (S.union s1 s2) (t1 || t2) +appendFsckOutput (FsckOutput s t) _ = FsckOutput s t +appendFsckOutput _ (FsckOutput s t) = FsckOutput s t +appendFsckOutput NoFsckOutput NoFsckOutput = NoFsckOutput +appendFsckOutput AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning +appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning +appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + +instance Sem.Semigroup FsckOutput where + (<>) = appendFsckOutput + instance Monoid FsckOutput where mempty = NoFsckOutput - mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2) - mappend (FsckOutput s t) _ = FsckOutput s t - mappend _ (FsckOutput s t) = FsckOutput s t - mappend NoFsckOutput NoFsckOutput = NoFsckOutput - mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning - mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning - mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning {- Runs fsck to find some of the broken objects in the repository. - May not find all broken objects, if fsck fails on bad data in some of @@ -65,9 +72,7 @@ instance Monoid FsckOutput where -} findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do - supportsNoDangling <- (>= Git.Version.normalize "1.7.10") - <$> Git.Version.installed - let (command, params) = ("git", fsckParams supportsNoDangling r) + let (command, params) = ("git", fsckParams r) (command', params') <- if batchmode then toBatchCommand (command, params) else return (command, params) @@ -78,8 +83,8 @@ findBroken batchmode r = do , std_err = CreatePipe } (o1, o2) <- concurrently - (parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p)) - (parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p)) + (parseFsckOutput maxobjs r (stdoutHandle p)) + (parseFsckOutput maxobjs r (stderrHandle p)) fsckok <- checkSuccessProcess pid case mappend o1 o2 of FsckOutput badobjs truncated @@ -112,15 +117,15 @@ knownMissing (FsckFoundMissing s _) = s findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput -parseFsckOutput maxobjs r supportsNoDangling h = do +parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput +parseFsckOutput maxobjs r h = do ls <- lines <$> hGetContents h if null ls then return NoFsckOutput else if all ("duplicateEntries" `isInfixOf`) ls then return AllDuplicateEntriesWarning else do - let shas = findShas supportsNoDangling ls + let shas = findShas ls let !truncated = length shas > maxobjs missingobjs <- findMissing (take maxobjs shas) r return $ FsckOutput missingobjs truncated @@ -133,18 +138,14 @@ isMissing s r = either (const True) (const False) <$> tryIO dump , Param (fromRef s) ] r -findShas :: Bool -> [String] -> [Sha] -findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted +findShas :: [String] -> [Sha] +findShas = catMaybes . map extractSha . concat . map words . filter wanted where - wanted l - | supportsNoDangling = True - | otherwise = not ("dangling " `isPrefixOf` l) - -fsckParams :: Bool -> Repo -> [CommandParam] -fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes - [ Just "fsck" - , if supportsNoDangling - then Just "--no-dangling" - else Nothing - , Just "--no-reflogs" + wanted l = not ("dangling " `isPrefixOf` l) + +fsckParams :: Repo -> [CommandParam] +fsckParams = gitCommandLine $ map Param + [ "fsck" + , "--no-dangling" + , "--no-reflogs" ] diff --git a/Git/HashObject.hs b/Git/HashObject.hs new file mode 100644 index 0000000..3787c9c --- /dev/null +++ b/Git/HashObject.hs @@ -0,0 +1,76 @@ +{- git hash-object interface + - + - Copyright 2011-2019 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.HashObject where + +import Common +import Git +import Git.Sha +import Git.Command +import Git.Types +import qualified Utility.CoProcess as CoProcess +import Utility.Tmp + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Builder + +type HashObjectHandle = CoProcess.CoProcessHandle + +hashObjectStart :: Bool -> Repo -> IO HashObjectHandle +hashObjectStart writeobject = gitCoProcessStart True $ catMaybes + [ Just (Param "hash-object") + , if writeobject then Just (Param "-w") else Nothing + , Just (Param "--stdin-paths") + , Just (Param "--no-filters") + ] + +hashObjectStop :: HashObjectHandle -> IO () +hashObjectStop = CoProcess.stop + +{- Injects a file into git, returning the Sha of the object. -} +hashFile :: HashObjectHandle -> FilePath -> IO Sha +hashFile h file = CoProcess.query h send receive + where + send to = hPutStrLn to =<< absPath file + receive from = getSha "hash-object" $ hGetLine from + +class HashableBlob t where + hashableBlobToHandle :: Handle -> t -> IO () + +instance HashableBlob L.ByteString where + hashableBlobToHandle = L.hPut + +instance HashableBlob S.ByteString where + hashableBlobToHandle = S.hPut + +instance HashableBlob Builder where + hashableBlobToHandle = hPutBuilder + +{- Injects a blob into git. Unfortunately, the current git-hash-object + - interface does not allow batch hashing without using temp files. -} +hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha +hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do + hashableBlobToHandle tmph b + hClose tmph + hashFile h tmp + +{- Injects some content into git, returning its Sha. + - + - Avoids using a tmp file, but runs a new hash-object command each + - time called. -} +hashObject :: ObjectType -> String -> Repo -> IO Sha +hashObject objtype content = hashObject' objtype (flip hPutStr content) + +hashObject' :: ObjectType -> (Handle -> IO ()) -> Repo -> IO Sha +hashObject' objtype writer repo = getSha subcmd $ + pipeWriteRead (map Param params) (Just writer) repo + where + subcmd = "hash-object" + params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"] diff --git a/Git/Index.hs b/Git/Index.hs index 85ea480..afd29c2 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -1,8 +1,8 @@ {- git index file stuff - - - Copyright 2011 Joey Hess <id@joeyh.name> + - Copyright 2011-2018 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Index where @@ -10,6 +10,7 @@ module Git.Index where import Common import Git import Utility.Env +import Utility.Env.Set indexEnv :: String indexEnv = "GIT_INDEX_FILE" @@ -46,25 +47,14 @@ override index _r = do reset (Just v) = setEnv indexEnv v True reset _ = unsetEnv var +{- The normal index file. Does not check GIT_INDEX_FILE. -} indexFile :: Repo -> FilePath -indexFile r = localGitDir r </> "index" +indexFile r = fromRawFilePath (localGitDir r) </> "index" -{- Git locks the index by creating this file. -} -indexFileLock :: Repo -> FilePath -indexFileLock r = indexFile r ++ ".lock" +{- The index file git will currently use, checking GIT_INDEX_FILE. -} +currentIndexFile :: Repo -> IO FilePath +currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv -{- When the pre-commit hook is run, and git commit has been run with - - a file or files specified to commit, rather than committing the staged - - index, git provides the pre-commit hook with a "false index file". - - - - Changes made to this index will influence the commit, but won't - - affect the real index file. - - - - This detects when we're in this situation, using a heuristic, which - - might be broken by changes to git. Any use of this should have a test - - case to make sure it works. - -} -haveFalseIndex :: IO Bool -haveFalseIndex = maybe (False) check <$> getEnv indexEnv - where - check f = "next-index" `isPrefixOf` takeFileName f +{- Git locks the index by creating this file. -} +indexFileLock :: FilePath -> FilePath +indexFileLock f = f ++ ".lock" diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index f945838..5534307 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -1,13 +1,15 @@ {- git ls-files interface - - - Copyright 2010,2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2018 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.LsFiles ( inRepo, + inRepoOrBranch, notInRepo, + notInRepoIncludingEmptyDirectories, allFiles, deleted, modified, @@ -32,69 +34,89 @@ import Git.Sha import Numeric import System.Posix.Types +import qualified Data.ByteString.Lazy as L -{- Scans for files that are checked into git at the specified locations. -} -inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -inRepo l = pipeNullSplit $ - Param "ls-files" : - Param "--cached" : - Param "-z" : - Param "--" : - map File l +{- Scans for files that are checked into git's index at the specified locations. -} +inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo = inRepo' [] + +inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo' ps l repo = pipeNullSplit' params repo + where + params = + Param "ls-files" : + Param "--cached" : + Param "-z" : + ps ++ + (Param "--" : map (File . fromRawFilePath) l) + +{- Files that are checked into the index or have been committed to a + - branch. -} +inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] {- Scans for files at the specified locations that are not checked into git. -} -notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -notInRepo include_ignored l repo = pipeNullSplit params repo +notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo = notInRepo' [] + +notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo' ps include_ignored l repo = pipeNullSplit' params repo where params = concat [ [ Param "ls-files", Param "--others"] + , ps , exclude , [ Param "-z", Param "--" ] - , map File l + , map (File . fromRawFilePath) l ] exclude | include_ignored = [] | otherwise = [Param "--exclude-standard"] +{- Scans for files at the specified locations that are not checked into + - git. Empty directories are included in the result. -} +notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] + {- Finds all files in the specified locations, whether checked into git or - not. -} -allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -allFiles l = pipeNullSplit $ +allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +allFiles l = pipeNullSplit' $ Param "ls-files" : Param "--cached" : Param "--others" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - deleted. -} -deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -deleted l repo = pipeNullSplit params repo +deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +deleted l repo = pipeNullSplit' params repo where params = Param "ls-files" : Param "--deleted" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - modified. -} -modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -modified l repo = pipeNullSplit params repo +modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modified l repo = pipeNullSplit' params repo where params = Param "ls-files" : Param "--modified" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Files that have been modified or are not checked into git (and are not - ignored). -} -modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -modifiedOthers l repo = pipeNullSplit params repo +modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modifiedOthers l repo = pipeNullSplit' params repo where params = Param "ls-files" : @@ -103,69 +125,69 @@ modifiedOthers l repo = pipeNullSplit params repo Param "--exclude-standard" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of all files that are staged for commit. -} -staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) staged = staged' [] {- Returns a list of the files, staged for commit, that are being added, - moved, or changed (but not deleted), from the specified locations. -} -stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] -staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix +staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] - suffix = Param "--" : map File l + suffix = Param "--" : map (File . fromRawFilePath) l -type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode) +type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode) {- Returns details about files that are staged in the index, - as well as files not yet in git. Skips ignored files. -} -stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"] {- Returns details about all files that are staged in the index. -} -stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails = stagedDetails' [] {- Gets details about staged files, including the Sha of their staged - contents. -} -stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' ps l repo = do (ls, cleanup) <- pipeNullSplit params repo return (map parse ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ - Param "--" : map File l + Param "--" : map (File . fromRawFilePath) l parse s - | null file = (s, Nothing, Nothing) - | otherwise = (file, extractSha $ take shaSize rest, readmode mode) + | null file = (L.toStrict s, Nothing, Nothing) + | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode) where - (metadata, file) = separate (== '\t') s + (metadata, file) = separate (== '\t') (decodeBL' s) (mode, rest) = separate (== ' ') metadata readmode = fst <$$> headMaybe . readOct {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} -typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChangedStaged = typeChanged' [Param "--cached"] {- Returns a list of the files in the specified locations whose type has - changed. Files only staged for commit will not be included. -} -typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged = typeChanged' [] -typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged' ps l repo = do (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. - top <- absPath (repoPath repo) + top <- absPath (fromRawFilePath (repoPath repo)) currdir <- getCurrentDirectory - return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup) + return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup) where prefix = [ Param "diff" @@ -173,7 +195,7 @@ typeChanged' ps l repo = do , Param "--diff-filter=T" , Param "-z" ] - suffix = Param "--" : (if null l then [File "."] else map File l) + suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l) {- A item in conflict has two possible values. - Either can be Nothing, when that side deleted the file. -} @@ -183,10 +205,10 @@ data Conflicting v = Conflicting } deriving (Show) data Unmerged = Unmerged - { unmergedFile :: FilePath - , unmergedBlobType :: Conflicting BlobType + { unmergedFile :: RawFilePath + , unmergedTreeItemType :: Conflicting TreeItemType , unmergedSha :: Conflicting Sha - } deriving (Show) + } {- Returns a list of the files in the specified locations that have - unresolved merge conflicts. @@ -198,38 +220,38 @@ data Unmerged = Unmerged - 3 = them - If a line is omitted, that side removed the file. -} -unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool) +unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) unmerged l repo = do (fs, cleanup) <- pipeNullSplit params repo - return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup) + return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) where params = Param "ls-files" : Param "--unmerged" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l data InternalUnmerged = InternalUnmerged { isus :: Bool - , ifile :: FilePath - , iblobtype :: Maybe BlobType + , ifile :: RawFilePath + , itreeitemtype :: Maybe TreeItemType , isha :: Maybe Sha - } deriving (Show) + } parseUnmerged :: String -> Maybe InternalUnmerged parseUnmerged s | null file = Nothing | otherwise = case words metadata of - (rawblobtype:rawsha:rawstage:_) -> do + (rawtreeitemtype:rawsha:rawstage:_) -> do stage <- readish rawstage :: Maybe Int if stage /= 2 && stage /= 3 then Nothing else do - blobtype <- readBlobType rawblobtype + treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) sha <- extractSha rawsha - return $ InternalUnmerged (stage == 2) file - (Just blobtype) (Just sha) + return $ InternalUnmerged (stage == 2) (toRawFilePath file) + (Just treeitemtype) (Just sha) _ -> Nothing where (metadata, file) = separate (== '\t') s @@ -239,12 +261,12 @@ reduceUnmerged c [] = c reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest where (rest, sibi) = findsib i is - (blobtypeA, blobtypeB, shaA, shaB) - | isus i = (iblobtype i, iblobtype sibi, isha i, isha sibi) - | otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i) + (treeitemtypeA, treeitemtypeB, shaA, shaB) + | isus i = (itreeitemtype i, itreeitemtype sibi, isha i, isha sibi) + | otherwise = (itreeitemtype sibi, itreeitemtype i, isha sibi, isha i) new = Unmerged { unmergedFile = ifile i - , unmergedBlobType = Conflicting blobtypeA blobtypeB + , unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB , unmergedSha = Conflicting shaA shaB } findsib templatei [] = ([], removed templatei) @@ -253,6 +275,6 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest | otherwise = (l:ls, removed templatei) removed templatei = templatei { isus = not (isus templatei) - , iblobtype = Nothing + , itreeitemtype = Nothing , isha = Nothing } diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 225f2ce..a3d8383 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,19 +1,21 @@ {- git ls-tree interface - - - Copyright 2011-2016 Joey Hess <id@joeyh.name> + - Copyright 2011-2019 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} module Git.LsTree ( TreeItem(..), + LsTreeMode(..), lsTree, lsTree', lsTreeParams, lsTreeFiles, parseLsTree, + formatLsTree, ) where import Common @@ -22,42 +24,52 @@ import Git.Command import Git.Sha import Git.FilePath import qualified Git.Filename +import Utility.Attoparsec import Numeric -import Data.Char +import Data.Either import System.Posix.Types +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 data TreeItem = TreeItem { mode :: FileMode - , typeobj :: String + , typeobj :: S.ByteString , sha :: Ref , file :: TopFilePath } deriving Show -{- Lists the complete contents of a tree, recursing into sub-trees, - - with lazy output. -} -lsTree :: Ref -> Repo -> IO ([TreeItem], IO Bool) +data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive + +{- Lists the contents of a tree, with lazy output. -} +lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) lsTree = lsTree' [] -lsTree' :: [CommandParam] -> Ref -> Repo -> IO ([TreeItem], IO Bool) -lsTree' ps t repo = do - (l, cleanup) <- pipeNullSplit (lsTreeParams t ps) repo - return (map parseLsTree l, cleanup) +lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree' ps lsmode t repo = do + (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo + return (rights (map parseLsTree l), cleanup) -lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] -lsTreeParams r ps = +lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] +lsTreeParams lsmode r ps = [ Param "ls-tree" , Param "--full-tree" , Param "-z" - , Param "-r" - ] ++ ps ++ + ] ++ recursiveparams ++ ps ++ [ Param "--" , File $ fromRef r ] + where + recursiveparams = case lsmode of + LsTreeRecursive -> [ Param "-r" ] + LsTreeNonRecursive -> [] {- Lists specified files in a tree. -} lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] -lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo +lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict) + <$> pipeNullSplitStrict ps repo where ps = [ Param "ls-tree" @@ -67,21 +79,34 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo , File $ fromRef t ] ++ map File fs +parseLsTree :: L.ByteString -> Either String TreeItem +parseLsTree b = case A.parse parserLsTree b of + A.Done _ r -> Right r + A.Fail _ _ err -> Left err + {- Parses a line of ls-tree output, in format: - mode SP type SP sha TAB file - - (The --long format is not currently supported.) -} -parseLsTree :: String -> TreeItem -parseLsTree l = TreeItem - { mode = smode - , typeobj = t - , sha = Ref s - , file = sfile - } - where - (m, past_m) = splitAt 7 l -- mode is 6 bytes - (!t, past_t) = separate isSpace past_m - (!s, past_s) = splitAt shaSize past_t - !f = drop 1 past_s - !smode = fst $ Prelude.head $ readOct m - !sfile = asTopFilePath $ Git.Filename.decode f +parserLsTree :: A.Parser TreeItem +parserLsTree = TreeItem + -- mode + <$> octal + <* A8.char ' ' + -- type + <*> A.takeTill (== 32) + <* A8.char ' ' + -- sha + <*> (Ref . decodeBS' <$> A.take shaSize) + <* A8.char '\t' + -- file + <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString) + +{- Inverse of parseLsTree -} +formatLsTree :: TreeItem -> String +formatLsTree ti = unwords + [ showOct (mode ti) "" + , decodeBS (typeobj ti) + , fromRef (sha ti) + , fromRawFilePath (getTopFilePath (file ti)) + ] diff --git a/Git/Objects.hs b/Git/Objects.hs index bda220b..c9ede4d 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Objects where @@ -12,7 +12,7 @@ import Git import Git.Sha objectsDir :: Repo -> FilePath -objectsDir r = localGitDir r </> "objects" +objectsDir r = fromRawFilePath (localGitDir r) </> "objects" packDir :: Repo -> FilePath packDir r = objectsDir r </> "pack" @@ -1,10 +1,12 @@ {- git ref stuff - - - Copyright 2011-2013 Joey Hess <id@joeyh.name> + - Copyright 2011-2019 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Ref where import Common @@ -13,13 +15,14 @@ import Git.Command import Git.Sha import Git.Types -import Data.Char (chr) +import Data.Char (chr, ord) +import qualified Data.ByteString as S headRef :: Ref headRef = Ref "HEAD" headFile :: Repo -> FilePath -headFile r = localGitDir r </> "HEAD" +headFile r = fromRawFilePath (localGitDir r) </> "HEAD" setHeadRef :: Ref -> Repo -> IO () setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) @@ -33,11 +36,18 @@ describe = fromRef . base - Converts such a fully qualified ref into a base ref - (eg: master or origin/master). -} base :: Ref -> Ref -base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef +base = removeBase "refs/heads/" . removeBase "refs/remotes/" + +{- Removes a directory such as "refs/heads/master" from a + - fully qualified ref. Any ref not starting with it is left as-is. -} +removeBase :: String -> Ref -> Ref +removeBase dir (Ref r) + | prefix `isPrefixOf` r = Ref (drop (length prefix) r) + | otherwise = Ref r where - remove prefix s - | prefix `isPrefixOf` s = drop (length prefix) s - | otherwise = s + prefix = case end dir of + ['/'] -> dir + _ -> dir ++ "/" {- Given a directory such as "refs/remotes/origin", and a ref such as - refs/heads/master, yields a version of that ref under the directory, @@ -55,8 +65,8 @@ branchRef = underBase "refs/heads" - Prefixing the file with ./ makes this work even if in a subdirectory - of a repo. -} -fileRef :: FilePath -> Ref -fileRef f = Ref $ ":./" ++ f +fileRef :: RawFilePath -> Ref +fileRef f = Ref $ ":./" ++ fromRawFilePath f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref @@ -64,7 +74,7 @@ dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d {- A Ref that can be used to refer to a file in the repository as it - appears in a given Ref. -} -fileFromRef :: Ref -> FilePath -> Ref +fileFromRef :: Ref -> RawFilePath -> Ref fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr) {- Checks if a ref exists. -} @@ -75,24 +85,29 @@ exists ref = runBool {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -} file :: Ref -> Repo -> FilePath -file ref repo = localGitDir repo </> fromRef ref +file ref repo = fromRawFilePath (localGitDir repo) </> fromRef ref {- Checks if HEAD exists. It generally will, except for in a repository - that was just created. -} headExists :: Repo -> IO Bool headExists repo = do - ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo - return $ any (" HEAD" `isSuffixOf`) ls + ls <- S.split nl <$> pipeReadStrict [Param "show-ref", Param "--head"] repo + return $ any (" HEAD" `S.isSuffixOf`) ls + where + nl = fromIntegral (ord '\n') {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) sha branch repo = process <$> showref repo where - showref = pipeReadStrict [Param "show-ref", - Param "--hash", -- get the hash - Param $ fromRef branch] - process [] = Nothing - process s = Just $ Ref $ firstLine s + showref = pipeReadStrict + [ Param "show-ref" + , Param "--hash" -- get the hash + , Param $ fromRef branch + ] + process s + | S.null s = Nothing + | otherwise = Just $ Ref $ decodeBS' $ firstLine' s headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef @@ -107,7 +122,7 @@ matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo {- List of (shas, branches) matching a given ref spec. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)] -matching' ps repo = map gen . lines <$> +matching' ps repo = map gen . lines . decodeBS' <$> pipeReadStrict (Param "show-ref" : map Param ps) repo where gen l = let (r, b) = separate (== ' ') l @@ -134,10 +149,13 @@ delete oldvalue ref = run , Param $ fromRef oldvalue ] -{- Gets the sha of the tree a ref uses. -} +{- Gets the sha of the tree a ref uses. + - + - The ref may be something like a branch name, and it could contain + - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree (Ref ref) = extractSha <$$> pipeReadStrict - [ Param "rev-parse", Param ref' ] +tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict + [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] where ref' = if ":" `isInfixOf` ref then ref diff --git a/Git/RefLog.hs b/Git/RefLog.hs index 57f35e9..7ba8713 100644 --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.RefLog where @@ -21,7 +21,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha] getMulti bs = get' (map (Param . fromRef) bs) get' :: [CommandParam] -> Repo -> IO [Sha] -get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps' +get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps' where ps' = catMaybes [ Just $ Param "log" diff --git a/Git/Remote.hs b/Git/Remote.hs index f6eaf93..69d6b52 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -2,10 +2,11 @@ - - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Remote where @@ -15,11 +16,22 @@ import Git.Types import Data.Char import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Network.URI #ifdef mingw32_HOST_OS import Git.FilePath #endif +{- Is a git config key one that specifies the location of a remote? -} +isRemoteKey :: ConfigKey -> Bool +isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k + +{- Get a remote's name from the config key that specifies its location. -} +remoteKeyToRemoteName :: ConfigKey -> RemoteName +remoteKeyToRemoteName (ConfigKey k) = decodeBS' $ + S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k + {- Construct a legal git remote name out of an arbitrary input string. - - There seems to be no formal definition of this in the git source, @@ -43,6 +55,7 @@ makeLegalName s = case filter legal $ replace "/" "_" s of legal c = isAlphaNum c data RemoteLocation = RemoteUrl String | RemotePath FilePath + deriving (Eq) remoteLocationIsUrl :: RemoteLocation -> Bool remoteLocationIsUrl (RemoteUrl _) = True @@ -67,16 +80,16 @@ parseRemoteLocation s repo = ret $ calcloc s -- insteadof config can rewrite remote location calcloc l | null insteadofs = l - | otherwise = replacement ++ drop (length bestvalue) l + | otherwise = replacement ++ drop (S.length bestvalue) l where - replacement = drop (length prefix) $ - take (length bestkey - length suffix) bestkey - (bestkey, bestvalue) = maximumBy longestvalue insteadofs + replacement = decodeBS' $ S.drop (S.length prefix) $ + S.take (S.length bestkey - S.length suffix) bestkey + (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(k, v) -> - prefix `isPrefixOf` k && - suffix `isSuffixOf` k && - v `isPrefixOf` l + insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> + prefix `S.isPrefixOf` k && + suffix `S.isSuffixOf` k && + v `S.isPrefixOf` encodeBS l filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs @@ -104,5 +117,5 @@ parseRemoteLocation s repo = ret $ calcloc s -- git on Windows will write a path to .git/config with "drive:", -- which is not to be confused with a "host:" dosstyle = hasDrive - dospath = fromInternalGitPath + dospath = fromRawFilePath . fromInternalGitPath . toRawFilePath #endif diff --git a/Git/Repair.hs b/Git/Repair.hs index 8e43248..66e6811 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Repair ( @@ -11,7 +11,6 @@ module Git.Repair ( removeBadBranches, successfulRepair, cleanCorruptObjects, - retrieveMissingObjects, resetLocalBranches, checkIndex, checkIndexFast, @@ -36,7 +35,7 @@ import qualified Git.Ref as Ref import qualified Git.RefLog as RefLog import qualified Git.UpdateIndex as UpdateIndex import qualified Git.Branch as Branch -import Utility.Tmp +import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode import Utility.Tuple @@ -102,10 +101,11 @@ retrieveMissingObjects missing referencerepo r unlessM (boolSystem "git" [Param "init", File tmpdir]) $ error $ "failed to create temp repository in " ++ tmpdir tmpr <- Config.read =<< Construct.fromAbsPath tmpdir - stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing + rs <- Construct.fromRemotes r + stillmissing <- pullremotes tmpr rs fetchrefstags missing if S.null (knownMissing stillmissing) then return stillmissing - else pullremotes tmpr (remotes r) fetchallrefs stillmissing + else pullremotes tmpr rs fetchallrefs stillmissing where pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of Nothing -> return stillmissing @@ -227,7 +227,7 @@ badBranches missing r = filterM isbad =<< getAllRefs r - Relies on packed refs being exploded before it's called. -} getAllRefs :: Repo -> IO [Ref] -getAllRefs r = getAllRefs' (localGitDir r </> "refs") +getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do @@ -245,13 +245,13 @@ explodePackedRefsFile r = do nukeFile f where makeref (sha, ref) = do - let dest = localGitDir r </> fromRef ref + let dest = fromRawFilePath (localGitDir r) </> fromRef ref createDirectoryIfMissing True (parentDir dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) packedRefsFile :: Repo -> FilePath -packedRefsFile r = localGitDir r </> "packed-refs" +packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of @@ -263,7 +263,7 @@ parsePacked l = case words l of {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = nukeFile $ localGitDir r </> fromRef b +nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) </> fromRef b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -284,7 +284,7 @@ findUncorruptedCommit missing goodcommits branch r = do , Param "--format=%H" , Param (fromRef branch) ] r - let branchshas = catMaybes $ map extractSha ls + let branchshas = catMaybes $ map (extractSha . decodeBL) ls reflogshas <- RefLog.get branch r -- XXX Could try a bit harder here, and look -- for uncorrupted old commits in branches in the @@ -313,7 +313,7 @@ verifyCommit missing goodcommits commit r , Param "--format=%H %T" , Param (fromRef commit) ] r - let committrees = map parse ls + let committrees = map (parse . decodeBL) ls if any isNothing committrees || null committrees then do void cleanup @@ -341,8 +341,8 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool verifyTree missing treesha r | S.member treesha missing = return False | otherwise = do - (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r - let objshas = map (LsTree.sha . LsTree.parseLsTree) ls + (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r + let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls if any (`S.member` missing) objshas then do void cleanup @@ -370,7 +370,7 @@ checkIndexFast r = do length indexcontents `seq` cleanup missingIndex :: Repo -> IO Bool -missingIndex r = not <$> doesFileExist (localGitDir r </> "index") +missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) </> "index") {- Finds missing and ok files staged in the index. -} partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) @@ -394,12 +394,12 @@ rewriteIndex r UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map fst3 bad + return $ map (fromRawFilePath . fst3) bad where - reinject (file, Just sha, Just mode) = case toBlobType mode of + reinject (file, Just sha, Just mode) = case toTreeItemType mode of Nothing -> return Nothing - Just blobtype -> Just <$> - UpdateIndex.stageFile sha blobtype file r + Just treeitemtype -> Just <$> + UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r reinject _ = return Nothing newtype GoodCommits = GoodCommits (S.Set Sha) @@ -446,7 +446,7 @@ preRepair g = do let f = indexFile g void $ tryIO $ allowWrite f where - headfile = localGitDir g </> "HEAD" + headfile = fromRawFilePath (localGitDir g) </> "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) {- Put it all together. -} @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Sha where diff --git a/Git/Types.hs b/Git/Types.hs index 327c1d7..9c2754a 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,16 +1,23 @@ {- git data types - - - Copyright 2010-2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2019 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Git.Types where import Network.URI +import Data.String +import Data.Default import qualified Data.Map as M +import qualified Data.ByteString as S import System.Posix.Types import Utility.SafeCommand +import Utility.FileSystemEncoding {- Support repositories on local disk, and repositories accessed via an URL. - @@ -23,19 +30,19 @@ import Utility.SafeCommand - else known about it. -} data RepoLocation - = Local { gitdir :: FilePath, worktree :: Maybe FilePath } - | LocalUnknown FilePath + = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath } + | LocalUnknown RawFilePath | Url URI | Unknown deriving (Show, Eq, Ord) data Repo = Repo { location :: RepoLocation - , config :: M.Map String String + , config :: M.Map ConfigKey ConfigValue -- a given git config key can actually have multiple values - , fullconfig :: M.Map String [String] - , remotes :: [Repo] - -- remoteName holds the name used for this repo in remotes + , fullconfig :: M.Map ConfigKey [ConfigValue] + -- remoteName holds the name used for this repo in some other + -- repo's list of remotes, when this repo is such a remote , remoteName :: Maybe RemoteName -- alternate environment to use when running git commands , gitEnv :: Maybe [(String, String)] @@ -44,6 +51,33 @@ data Repo = Repo , gitGlobalOpts :: [CommandParam] } deriving (Show, Eq, Ord) +newtype ConfigKey = ConfigKey S.ByteString + deriving (Ord, Eq) + +newtype ConfigValue = ConfigValue S.ByteString + deriving (Ord, Eq, Semigroup, Monoid) + +instance Default ConfigValue where + def = ConfigValue mempty + +fromConfigKey :: ConfigKey -> String +fromConfigKey (ConfigKey s) = decodeBS' s + +instance Show ConfigKey where + show = fromConfigKey + +fromConfigValue :: ConfigValue -> String +fromConfigValue (ConfigValue s) = decodeBS' s + +instance Show ConfigValue where + show = fromConfigValue + +instance IsString ConfigKey where + fromString = ConfigKey . encodeBS' + +instance IsString ConfigValue where + fromString = ConfigValue . encodeBS' + type RemoteName = String {- A git ref. Can be a sha1, or a branch or tag name. -} @@ -64,45 +98,48 @@ newtype RefDate = RefDate String {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject - deriving (Eq) - -instance Show ObjectType where - show BlobObject = "blob" - show CommitObject = "commit" - show TreeObject = "tree" -readObjectType :: String -> Maybe ObjectType +readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject readObjectType "commit" = Just CommitObject readObjectType "tree" = Just TreeObject readObjectType _ = Nothing -{- Types of blobs. -} -data BlobType = FileBlob | ExecutableBlob | SymlinkBlob - deriving (Eq) - -{- Git uses magic numbers to denote the type of a blob. -} -instance Show BlobType where - show FileBlob = "100644" - show ExecutableBlob = "100755" - show SymlinkBlob = "120000" - -readBlobType :: String -> Maybe BlobType -readBlobType "100644" = Just FileBlob -readBlobType "100755" = Just ExecutableBlob -readBlobType "120000" = Just SymlinkBlob -readBlobType _ = Nothing - -toBlobType :: FileMode -> Maybe BlobType -toBlobType 0o100644 = Just FileBlob -toBlobType 0o100755 = Just ExecutableBlob -toBlobType 0o120000 = Just SymlinkBlob -toBlobType _ = Nothing - -fromBlobType :: BlobType -> FileMode -fromBlobType FileBlob = 0o100644 -fromBlobType ExecutableBlob = 0o100755 -fromBlobType SymlinkBlob = 0o120000 +fmtObjectType :: ObjectType -> S.ByteString +fmtObjectType BlobObject = "blob" +fmtObjectType CommitObject = "commit" +fmtObjectType TreeObject = "tree" + +{- Types of items in a tree. -} +data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule + deriving (Eq, Show) + +{- Git uses magic numbers to denote the type of a tree item. -} +readTreeItemType :: S.ByteString -> Maybe TreeItemType +readTreeItemType "100644" = Just TreeFile +readTreeItemType "100755" = Just TreeExecutable +readTreeItemType "120000" = Just TreeSymlink +readTreeItemType "160000" = Just TreeSubmodule +readTreeItemType _ = Nothing + +fmtTreeItemType :: TreeItemType -> S.ByteString +fmtTreeItemType TreeFile = "100644" +fmtTreeItemType TreeExecutable = "100755" +fmtTreeItemType TreeSymlink = "120000" +fmtTreeItemType TreeSubmodule = "160000" + +toTreeItemType :: FileMode -> Maybe TreeItemType +toTreeItemType 0o100644 = Just TreeFile +toTreeItemType 0o100755 = Just TreeExecutable +toTreeItemType 0o120000 = Just TreeSymlink +toTreeItemType 0o160000 = Just TreeSubmodule +toTreeItemType _ = Nothing + +fromTreeItemType :: TreeItemType -> FileMode +fromTreeItemType TreeFile = 0o100644 +fromTreeItemType TreeExecutable = 0o100755 +fromTreeItemType TreeSymlink = 0o120000 +fromTreeItemType TreeSubmodule = 0o160000 data Commit = Commit { commitTree :: Sha diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 7fdc945..9f07cf5 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,11 +1,11 @@ {- git-update-index library - - - Copyright 2011-2013 Joey Hess <id@joeyh.name> + - Copyright 2011-2019 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} module Git.UpdateIndex ( Streamer, @@ -21,6 +21,7 @@ module Git.UpdateIndex ( unstageFile, stageSymlink, stageDiffTreeItem, + refreshIndex, ) where import Common @@ -31,12 +32,14 @@ import Git.FilePath import Git.Sha import qualified Git.DiffTreeItem as Diff +import qualified Data.ByteString.Lazy as L + {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} -type Streamer = (String -> IO ()) -> IO () +type Streamer = (L.ByteString -> IO ()) -> IO () {- A streamer with a precalculated value. -} -pureStreamer :: String -> Streamer +pureStreamer :: L.ByteString -> Streamer pureStreamer !s = \streamer -> streamer s {- Streams content into update-index from a list of Streamers. -} @@ -48,8 +51,8 @@ data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do - hPutStr h s - hPutStr h "\0" + L.hPutStr h s + L.hPutStr h "\0" startUpdateIndex :: Repo -> IO UpdateIndexHandle startUpdateIndex repo = do @@ -83,38 +86,66 @@ lsSubTree (Ref x) p repo streamer = do {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} -updateIndexLine :: Sha -> BlobType -> TopFilePath -> String -updateIndexLine sha filetype file = - show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file - -stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer -stageFile sha filetype file repo = do - p <- toTopFilePath file repo - return $ pureStreamer $ updateIndexLine sha filetype p +updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString +updateIndexLine sha treeitemtype file = L.fromStrict $ + fmtTreeItemType treeitemtype + <> " blob " + <> encodeBS (fromRef sha) + <> "\t" + <> indexPath file + +stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer +stageFile sha treeitemtype file repo = do + p <- toTopFilePath (toRawFilePath file) repo + return $ pureStreamer $ updateIndexLine sha treeitemtype p {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do - p <- toTopFilePath file repo + p <- toTopFilePath (toRawFilePath file) repo return $ unstageFile' p unstageFile' :: TopFilePath -> Streamer -unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p +unstageFile' p = pureStreamer $ L.fromStrict $ + "0 " + <> encodeBS' (fromRef nullSha) + <> "\t" + <> indexPath p {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer stageSymlink file sha repo = do !line <- updateIndexLine <$> pure sha - <*> pure SymlinkBlob - <*> toTopFilePath file repo + <*> pure TreeSymlink + <*> toTopFilePath (toRawFilePath file) repo return $ pureStreamer line {- A streamer that applies a DiffTreeItem to the index. -} stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer -stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of +stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of Nothing -> unstageFile' (Diff.file d) Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d) indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath + +{- Refreshes the index, by checking file stat information. -} +refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool +refreshIndex repo feeder = do + (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) + { std_in = CreatePipe } + feeder $ \f -> do + hPutStr h f + hPutStr h "\0" + hFlush h + hClose h + checkSuccessProcess p + where + params = + [ Param "update-index" + , Param "-q" + , Param "--refresh" + , Param "-z" + , Param "--stdin" + ] @@ -2,7 +2,7 @@ - - Copyright 2010, 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Url ( @@ -11,9 +11,10 @@ module Git.Url ( port, hostuser, authority, + path, ) where -import Network.URI hiding (scheme, authority) +import Network.URI hiding (scheme, authority, path) import Common import Git.Types @@ -66,6 +67,11 @@ authpart :: (URIAuth -> a) -> Repo -> Maybe a authpart a Repo { location = Url u } = a <$> uriAuthority u authpart _ repo = notUrl repo +{- Path part of an URL repo. -} +path :: Repo -> FilePath +path Repo { location = Url u } = uriPath u +path repo = notUrl repo + notUrl :: Repo -> a notUrl repo = error $ "acting on local git repo " ++ repoDescribe repo ++ " not supported" diff --git a/Git/Version.hs b/Git/Version.hs index 19ff945..5ecaca0 100644 --- a/Git/Version.hs +++ b/Git/Version.hs @@ -2,7 +2,7 @@ - - Copyright 2011, 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-tabs #-} diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs index fce3c04..fcd6932 100644 --- a/Utility/Applicative.hs +++ b/Utility/Applicative.hs @@ -5,7 +5,11 @@ - License: BSD-2-clause -} -module Utility.Applicative where +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Applicative ( + (<$$>), +) where {- Like <$> , but supports one level of currying. - diff --git a/Utility/Attoparsec.hs b/Utility/Attoparsec.hs new file mode 100644 index 0000000..bd20e8e --- /dev/null +++ b/Utility/Attoparsec.hs @@ -0,0 +1,21 @@ +{- attoparsec utility functions + - + - Copyright 2019 Joey Hess <id@joeyh.name> + - Copyright 2007-2015 Bryan O'Sullivan + - + - License: BSD-3-clause + -} + +module Utility.Attoparsec where + +import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString as B + +-- | Parse and decode an unsigned octal number. +-- +-- This parser does not accept a leading @\"0o\"@ string. +octal :: Integral a => A.Parser a +octal = B.foldl' step 0 `fmap` A.takeWhile1 isOctDigit + where + isOctDigit w = w >= 48 && w <= 55 + step a w = a * 8 + fromIntegral (w - 48) diff --git a/Utility/Batch.hs b/Utility/Batch.hs index d96f9d3..1d66881 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -7,11 +7,18 @@ {-# LANGUAGE CPP #-} -module Utility.Batch where +module Utility.Batch ( + batch, + BatchCommandMaker, + getBatchCommandMaker, + toBatchCommand, + batchCommand, + batchCommandEnv, +) where import Common -#if defined(linux_HOST_OS) || defined(__ANDROID__) +#if defined(linux_HOST_OS) import Control.Concurrent.Async import System.Posix.Process #endif @@ -29,7 +36,7 @@ import qualified Control.Exception as E - systems, the action is simply ran. -} batch :: IO a -> IO a -#if defined(linux_HOST_OS) || defined(__ANDROID__) +#if defined(linux_HOST_OS) batch a = wait =<< batchthread where batchthread = asyncBound $ do @@ -51,11 +58,7 @@ getBatchCommandMaker = do #ifndef mingw32_HOST_OS nicers <- filterM (inPath . fst) [ ("nice", []) -#ifndef __ANDROID__ - -- Android's ionice does not allow specifying a command, - -- so don't use it. , ("ionice", ["-c3"]) -#endif , ("nocache", []) ] return $ \(command, params) -> diff --git a/Utility/Data.hs b/Utility/Data.hs index 27c0a82..5510845 100644 --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -7,7 +7,10 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Data where +module Utility.Data ( + firstJust, + eitherToMaybe, +) where {- First item in the list that is not Nothing. -} firstJust :: Eq a => [Maybe a] -> Maybe a diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 895581d..e2c6a94 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -18,15 +18,11 @@ import Control.Monad import System.FilePath import System.PosixCompat.Files import Control.Applicative -import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe import Prelude -#ifdef mingw32_HOST_OS -import qualified System.Win32 as Win32 -#else -import qualified System.Posix as Posix +#ifndef mingw32_HOST_OS import Utility.SafeCommand import Control.Monad.IfElse #endif @@ -158,90 +154,3 @@ nukeFile file = void $ tryWhenExists go #else go = removeFile file #endif - -#ifndef mingw32_HOST_OS -data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream -#else -data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ()) -#endif - -type IsOpen = MVar () -- full when the handle is open - -openDirectory :: FilePath -> IO DirectoryHandle -openDirectory path = do -#ifndef mingw32_HOST_OS - dirp <- Posix.openDirStream path - isopen <- newMVar () - return (DirectoryHandle isopen dirp) -#else - (h, fdat) <- Win32.findFirstFile (path </> "*") - -- Indicate that the fdat contains a filename that readDirectory - -- has not yet returned, by making the MVar be full. - -- (There's always at least a "." entry.) - alreadyhave <- newMVar () - isopen <- newMVar () - return (DirectoryHandle isopen h fdat alreadyhave) -#endif - -closeDirectory :: DirectoryHandle -> IO () -#ifndef mingw32_HOST_OS -closeDirectory (DirectoryHandle isopen dirp) = - whenOpen isopen $ - Posix.closeDirStream dirp -#else -closeDirectory (DirectoryHandle isopen h _ alreadyhave) = - whenOpen isopen $ do - _ <- tryTakeMVar alreadyhave - Win32.findClose h -#endif - where - whenOpen :: IsOpen -> IO () -> IO () - whenOpen mv f = do - v <- tryTakeMVar mv - when (isJust v) f - -{- |Reads the next entry from the handle. Once the end of the directory -is reached, returns Nothing and automatically closes the handle. --} -readDirectory :: DirectoryHandle -> IO (Maybe FilePath) -#ifndef mingw32_HOST_OS -readDirectory hdl@(DirectoryHandle _ dirp) = do - e <- Posix.readDirStream dirp - if null e - then do - closeDirectory hdl - return Nothing - else return (Just e) -#else -readDirectory hdl@(DirectoryHandle _ h fdat mv) = do - -- If the MVar is full, then the filename in fdat has - -- not yet been returned. Otherwise, need to find the next - -- file. - r <- tryTakeMVar mv - case r of - Just () -> getfn - Nothing -> do - more <- Win32.findNextFile h fdat - if more - then getfn - else do - closeDirectory hdl - return Nothing - where - getfn = do - filename <- Win32.getFindDataFileName fdat - return (Just filename) -#endif - --- True only when directory exists and contains nothing. --- Throws exception if directory does not exist. -isDirectoryEmpty :: FilePath -> IO Bool -isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check - where - check h = do - v <- readDirectory h - case v of - Nothing -> return True - Just f - | not (dirCruft f) -> return False - | otherwise -> check h diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs index 3198b1c..dff3717 100644 --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -7,7 +7,11 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.DottedVersion where +module Utility.DottedVersion ( + DottedVersion, + fromDottedVersion, + normalize, +) where import Common @@ -18,7 +22,10 @@ instance Ord DottedVersion where compare (DottedVersion _ x) (DottedVersion _ y) = compare x y instance Show DottedVersion where - show (DottedVersion s _) = s + show = fromDottedVersion + +fromDottedVersion :: DottedVersion -> String +fromDottedVersion (DottedVersion s _) = s {- To compare dotted versions like 1.7.7 and 1.8, they are normalized to - a somewhat arbitrary integer representation. -} diff --git a/Utility/Env.hs b/Utility/Env.hs index c56f4ec..9847326 100644 --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -8,7 +8,14 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Env where +module Utility.Env ( + getEnv, + getEnvDefault, + getEnvironment, + addEntry, + addEntries, + delEntry, +) where #ifdef mingw32_HOST_OS import Utility.Exception @@ -16,7 +23,6 @@ import Control.Applicative import Data.Maybe import Prelude import qualified System.Environment as E -import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif @@ -42,29 +48,6 @@ getEnvironment = PE.getEnvironment getEnvironment = E.getEnvironment #endif -{- Sets an environment variable. To overwrite an existing variable, - - overwrite must be True. - - - - On Windows, setting a variable to "" unsets it. -} -setEnv :: String -> String -> Bool -> IO () -#ifndef mingw32_HOST_OS -setEnv var val overwrite = PE.setEnv var val overwrite -#else -setEnv var val True = System.SetEnv.setEnv var val -setEnv var val False = do - r <- getEnv var - case r of - Nothing -> setEnv var val True - Just _ -> return () -#endif - -unsetEnv :: String -> IO () -#ifndef mingw32_HOST_OS -unsetEnv = PE.unsetEnv -#else -unsetEnv = System.SetEnv.unsetEnv -#endif - {- Adds the environment variable to the input environment. If already - present in the list, removes the old value. - diff --git a/Utility/Env/Basic.hs b/Utility/Env/Basic.hs new file mode 100644 index 0000000..db73827 --- /dev/null +++ b/Utility/Env/Basic.hs @@ -0,0 +1,25 @@ +{- portable environment variables, without any dependencies + - + - Copyright 2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Env.Basic ( + getEnv, + getEnvDefault, +) where + +import Utility.Exception +import Control.Applicative +import Data.Maybe +import Prelude +import qualified System.Environment as E + +getEnv :: String -> IO (Maybe String) +getEnv = catchMaybeIO . E.getEnv + +getEnvDefault :: String -> String -> IO String +getEnvDefault var fallback = fromMaybe fallback <$> getEnv var diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs new file mode 100644 index 0000000..f14674c --- /dev/null +++ b/Utility/Env/Set.hs @@ -0,0 +1,43 @@ +{- portable environment variables + - + - Copyright 2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Env.Set ( + setEnv, + unsetEnv, +) where + +#ifdef mingw32_HOST_OS +import qualified System.SetEnv +import Utility.Env +#else +import qualified System.Posix.Env as PE +#endif + +{- Sets an environment variable. To overwrite an existing variable, + - overwrite must be True. + - + - On Windows, setting a variable to "" unsets it. -} +setEnv :: String -> String -> Bool -> IO () +#ifndef mingw32_HOST_OS +setEnv var val overwrite = PE.setEnv var val overwrite +#else +setEnv var val True = System.SetEnv.setEnv var val +setEnv var val False = do + r <- getEnv var + case r of + Nothing -> setEnv var val True + Just _ -> return () +#endif + +unsetEnv :: String -> IO () +#ifndef mingw32_HOST_OS +unsetEnv = PE.unsetEnv +#else +unsetEnv = System.SetEnv.unsetEnv +#endif diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 67c2e85..bcadb78 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Exception ( @@ -29,11 +29,7 @@ module Utility.Exception ( import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException) -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) import Control.Exception (SomeAsyncException) -#endif -#endif import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType) @@ -46,15 +42,7 @@ import Utility.Data - where there's a problem that the user is excpected to see in some - circumstances. -} giveup :: [Char] -> a -#ifdef MIN_VERSION_base -#if MIN_VERSION_base(4,9,0) giveup = errorWithoutStackTrace -#else -giveup = error -#endif -#else -giveup = error -#endif {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool @@ -95,11 +83,7 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` [ M.Handler (\ (e :: AsyncException) -> throwM e) -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) , M.Handler (\ (e :: SomeAsyncException) -> throwM e) -#endif -#endif , M.Handler (\ (e :: SomeException) -> onerr e) ] diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 370bcf6..7d36c55 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -17,7 +17,7 @@ import Control.Monad import System.PosixCompat.Types import System.PosixCompat.Files #ifndef mingw32_HOST_OS -import System.Posix.Files +import System.Posix.Files (symbolicLinkMode) import Control.Monad.IO.Class (liftIO) #endif import Control.Monad.IO.Class (MonadIO) @@ -69,6 +69,7 @@ otherGroupModes :: [FileMode] otherGroupModes = [ groupReadMode, otherReadMode , groupWriteMode, otherWriteMode + , groupExecuteMode, otherExecuteMode ] {- Removes the write bits from a file. -} diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index 5f89cff..8544ad4 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -4,8 +4,13 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.FileSize where +module Utility.FileSize ( + FileSize, + getFileSize, + getFileSize', +) where import System.PosixCompat.Files #ifdef mingw32_HOST_OS @@ -28,7 +33,10 @@ getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) getFileSize f = bracket (openFile f ReadMode) hClose hFileSize #endif -{- Gets the size of the file, when its FileStatus is already known. -} +{- Gets the size of the file, when its FileStatus is already known. + - + - On windows, uses getFileSize. Otherwise, the FileStatus contains the + - size, so this does not do any work. -} getFileSize' :: FilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 444dc4a..f9e9814 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -12,12 +12,17 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, fileEncoding, withFilePath, + RawFilePath, + fromRawFilePath, + toRawFilePath, + decodeBL, + encodeBL, decodeBS, encodeBS, - decodeW8, - encodeW8, - encodeW8NUL, - decodeW8NUL, + decodeBL', + encodeBL', + decodeBS', + encodeBS', truncateFilePath, s2w8, w82s, @@ -32,8 +37,10 @@ import System.IO import System.IO.Unsafe import Data.Word import Data.List +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS +import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 #endif @@ -103,31 +110,91 @@ _encodeFilePath fp = unsafePerformIO $ do `catchNonAsync` (\_ -> return fp) {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} -decodeBS :: L.ByteString -> FilePath +decodeBL :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBS = encodeW8NUL . L.unpack +decodeBL = encodeW8NUL . L.unpack #else {- On Windows, we assume that the ByteString is utf-8, since Windows - only uses unicode for filenames. -} -decodeBS = L8.toString +decodeBL = L8.toString #endif {- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} -encodeBS :: FilePath -> L.ByteString +encodeBL :: FilePath -> L.ByteString #ifndef mingw32_HOST_OS -encodeBS = L.pack . decodeW8NUL +encodeBL = L.pack . decodeW8NUL #else -encodeBS = L8.fromString +encodeBL = L8.fromString #endif +decodeBS :: S.ByteString -> FilePath +#ifndef mingw32_HOST_OS +decodeBS = encodeW8NUL . S.unpack +#else +decodeBS = S8.toString +#endif + +encodeBS :: FilePath -> S.ByteString +#ifndef mingw32_HOST_OS +encodeBS = S.pack . decodeW8NUL +#else +encodeBS = S8.fromString +#endif + +{- Faster version that assumes the string does not contain NUL; + - if it does it will be truncated before the NUL. -} +decodeBS' :: S.ByteString -> FilePath +#ifndef mingw32_HOST_OS +decodeBS' = encodeW8 . S.unpack +#else +decodeBS' = S8.toString +#endif + +encodeBS' :: FilePath -> S.ByteString +#ifndef mingw32_HOST_OS +encodeBS' = S.pack . decodeW8 +#else +encodeBS' = S8.fromString +#endif + +decodeBL' :: L.ByteString -> FilePath +#ifndef mingw32_HOST_OS +decodeBL' = encodeW8 . L.unpack +#else +decodeBL' = L8.toString +#endif + +encodeBL' :: FilePath -> L.ByteString +#ifndef mingw32_HOST_OS +encodeBL' = L.pack . decodeW8 +#else +encodeBL' = L8.fromString +#endif + +{- Recent versions of the unix package have this alias; defined here + - for backwards compatibility. -} +type RawFilePath = S.ByteString + +{- Note that the RawFilePath is assumed to never contain NUL, + - since filename's don't. This should only be used with actual + - RawFilePaths not arbitrary ByteString that may contain NUL. -} +fromRawFilePath :: RawFilePath -> FilePath +fromRawFilePath = decodeBS' + +{- Note that the FilePath is assumed to never contain NUL, + - since filename's don't. This should only be used with actual FilePaths + - not arbitrary String that may contain NUL. -} +toRawFilePath :: FilePath -> RawFilePath +toRawFilePath = encodeBS' + {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - - w82c produces a String, which may contain Chars that are invalid + - w82s produces a String, which may contain Chars that are invalid - unicode. From there, this is really a simple matter of applying the - file system encoding, only complicated by GHC's interface to doing so. - - Note that the encoding stops at any NUL in the input. FilePaths - - do not normally contain embedded NUL, but Haskell Strings may. + - cannot contain embedded NUL, but Haskell Strings may. -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath @@ -135,8 +202,6 @@ encodeW8 w8 = unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc -{- Useful when you want the actual number of bytes that will be used to - - represent the FilePath on disk. -} decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath diff --git a/Utility/Format.hs b/Utility/Format.hs index 3670cd7..a2470fa 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -15,7 +15,7 @@ module Utility.Format ( ) where import Text.Printf (printf) -import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord) +import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord, isAscii) import Data.Maybe (fromMaybe) import Data.Word (Word8) import Data.List (isPrefixOf) @@ -176,12 +176,12 @@ encode_c' p = concatMap echar {- For quickcheck. - - Encoding and then decoding roundtrips only when - - the string does not contain high unicode, because eg, - - both "\12345" and "\227\128\185" are encoded to "\343\200\271". + - the string is ascii because eg, both "\12345" and + - "\227\128\185" are encoded to "\343\200\271". - - - This property papers over the problem, by only testing chars < 256. + - This property papers over the problem, by only testing ascii. -} prop_encode_c_decode_c_roundtrip :: String -> Bool prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s') where - s' = filter (\c -> ord c < 256) s + s' = filter isAscii s diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs index c3fede9..6143cef 100644 --- a/Utility/HumanNumber.hs +++ b/Utility/HumanNumber.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -module Utility.HumanNumber where +module Utility.HumanNumber (showImprecise) where {- Displays a fractional value as a string with a limited number - of decimal digits. -} diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index fe7cf22..01fbeac 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -60,15 +60,17 @@ parseDuration = maybe parsefail (return . Duration) . go 0 fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } | d == 0 = "0s" - | otherwise = concatMap showunit $ go [] units d + | otherwise = concatMap showunit $ take 2 $ go [] units d where - showunit (u, n) - | n > 0 = show n ++ [u] - | otherwise = "" + showunit (u, n) = show n ++ [u] go c [] _ = reverse c go c ((u, n):us) v = let (q,r) = v `quotRem` n - in go ((u, q):c) us r + in if q > 0 + then go ((u, q):c) us r + else if null c + then go c us r + else reverse c units :: [(Char, Integer)] units = diff --git a/Utility/Metered.hs b/Utility/Metered.hs index a5dda54..ec16e33 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,16 +1,48 @@ {- Metered IO and actions - - - Copyright 2012-2016 Joey Hess <id@joeyh.name> + - Copyright 2012-2018 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE TypeSynonymInstances, BangPatterns #-} -module Utility.Metered where +module Utility.Metered ( + MeterUpdate, + nullMeterUpdate, + combineMeterUpdate, + BytesProcessed(..), + toBytesProcessed, + fromBytesProcessed, + addBytesProcessed, + zeroBytesProcessed, + withMeteredFile, + meteredWrite, + meteredWrite', + meteredWriteFile, + offsetMeterUpdate, + hGetContentsMetered, + hGetMetered, + defaultChunkSize, + watchFileSize, + OutputHandler(..), + ProgressParser, + commandMeter, + commandMeter', + demeterCommand, + demeterCommandEnv, + avoidProgress, + rateLimitMeterUpdate, + Meter, + mkMeter, + setMeterTotalSize, + updateMeter, + displayMeterHandle, + clearMeterHandle, + bandwidthMeter, +) where import Common -import Utility.FileSystemEncoding import Utility.Percentage import Utility.DataUnits import Utility.HumanTime @@ -81,11 +113,6 @@ withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h -> hGetContentsMetered h meterupdate >>= a -{- Sends the content of a file to a Handle, updating the meter as it's - - written. -} -streamMeteredFile :: FilePath -> MeterUpdate -> Handle -> IO () -streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h - {- Writes a ByteString to a Handle, updating a meter as it's written. -} meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO () meteredWrite meterupdate h = void . meteredWrite' meterupdate h @@ -211,7 +238,14 @@ type ProgressParser = String -> (Maybe BytesProcessed, String) - to update a meter. -} commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool -commandMeter progressparser oh meterupdate cmd params = +commandMeter progressparser oh meterupdate cmd params = do + ret <- commandMeter' progressparser oh meterupdate cmd params + return $ case ret of + Just ExitSuccess -> True + _ -> False + +commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode) +commandMeter' progressparser oh meterupdate cmd params = outputFilter cmd params Nothing (feedprogress zeroBytesProcessed []) handlestderr @@ -224,7 +258,7 @@ commandMeter progressparser oh meterupdate cmd params = unless (quietMode oh) $ do S.hPut stdout b hFlush stdout - let s = encodeW8 (S.unpack b) + let s = decodeBS b let (mbytes, buf') = progressparser (buf++s) case mbytes of Nothing -> feedprogress prev buf' h @@ -246,9 +280,13 @@ demeterCommand :: OutputHandler -> FilePath -> [CommandParam] -> IO Bool demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool -demeterCommandEnv oh cmd params environ = outputFilter cmd params environ - (\outh -> avoidProgress True outh stdouthandler) - (\errh -> avoidProgress True errh $ stderrHandler oh) +demeterCommandEnv oh cmd params environ = do + ret <- outputFilter cmd params environ + (\outh -> avoidProgress True outh stdouthandler) + (\errh -> avoidProgress True errh $ stderrHandler oh) + return $ case ret of + Just ExitSuccess -> True + _ -> False where stdouthandler l = unless (quietMode oh) $ @@ -271,16 +309,15 @@ outputFilter -> Maybe [(String, String)] -> (Handle -> IO ()) -> (Handle -> IO ()) - -> IO Bool -outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do + -> IO (Maybe ExitCode) +outputFilter cmd params environ outfilter errfilter = catchMaybeIO $ do (_, Just outh, Just errh, pid) <- createProcess p { std_out = CreatePipe , std_err = CreatePipe } void $ async $ tryIO (outfilter outh) >> hClose outh void $ async $ tryIO (errfilter errh) >> hClose errh - ret <- checkSuccessProcess pid - return ret + waitForProcess pid where p = (proc cmd (toCommand params)) { env = environ } @@ -288,14 +325,14 @@ outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do -- | Limit a meter to only update once per unit of time. -- -- It's nice to display the final update to 100%, even if it comes soon --- after a previous update. To make that happen, a total size has to be --- provided. -rateLimitMeterUpdate :: NominalDiffTime -> Maybe Integer -> MeterUpdate -> IO MeterUpdate -rateLimitMeterUpdate delta totalsize meterupdate = do +-- after a previous update. To make that happen, the Meter has to know +-- its total size. +rateLimitMeterUpdate :: NominalDiffTime -> Meter -> MeterUpdate -> IO MeterUpdate +rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do lastupdate <- newMVar (toEnum 0 :: POSIXTime) return $ mu lastupdate where - mu lastupdate n@(BytesProcessed i) = case totalsize of + mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case Just t | i >= t -> meterupdate n _ -> do now <- getPOSIXTime @@ -306,35 +343,38 @@ rateLimitMeterUpdate delta totalsize meterupdate = do meterupdate n else putMVar lastupdate prev -data Meter = Meter (Maybe Integer) (MVar MeterState) (MVar String) RenderMeter DisplayMeter +data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter type MeterState = (BytesProcessed, POSIXTime) -type DisplayMeter = MVar String -> String -> IO () +type DisplayMeter = MVar String -> Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> IO () type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String -- | Make a meter. Pass the total size, if it's known. -mkMeter :: Maybe Integer -> RenderMeter -> DisplayMeter -> IO Meter -mkMeter totalsize rendermeter displaymeter = Meter - <$> pure totalsize +mkMeter :: Maybe Integer -> DisplayMeter -> IO Meter +mkMeter totalsize displaymeter = Meter + <$> newMVar totalsize <*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime) <*> newMVar "" - <*> pure rendermeter <*> pure displaymeter +setMeterTotalSize :: Meter -> Integer -> IO () +setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just + -- | Updates the meter, displaying it if necessary. -updateMeter :: Meter -> BytesProcessed -> IO () -updateMeter (Meter totalsize sv bv rendermeter displaymeter) new = do +updateMeter :: Meter -> MeterUpdate +updateMeter (Meter totalsizev sv bv displaymeter) new = do now <- getPOSIXTime (old, before) <- swapMVar sv (new, now) - when (old /= new) $ - displaymeter bv $ - rendermeter totalsize (old, before) (new, now) + when (old /= new) $ do + totalsize <- readMVar totalsizev + displaymeter bv totalsize (old, before) (new, now) -- | Display meter to a Handle. -displayMeterHandle :: Handle -> DisplayMeter -displayMeterHandle h v s = do +displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter +displayMeterHandle h rendermeter v msize old new = do + let s = rendermeter msize old new olds <- swapMVar v s -- Avoid writing when the rendered meter has not changed. when (olds /= s) $ do @@ -344,29 +384,32 @@ displayMeterHandle h v s = do -- | Clear meter displayed by displayMeterHandle. clearMeterHandle :: Meter -> Handle -> IO () -clearMeterHandle (Meter _ _ v _ _) h = do +clearMeterHandle (Meter _ _ v _) h = do olds <- readMVar v hPutStr h $ '\r' : replicate (length olds) ' ' ++ "\r" hFlush h -- | Display meter in the form: --- 10% 300 KiB/s 16m40s +-- 10% 1.3MiB 300 KiB/s 16m40s -- or when total size is not known: --- 1.3 MiB 300 KiB/s +-- 1.3 MiB 300 KiB/s bandwidthMeter :: RenderMeter bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) = unwords $ catMaybes - [ Just percentoramount - -- Pad enough for max width: "xxxx.xx KiB xxxx KiB/s" - , Just $ replicate (23 - length percentoramount - length rate) ' ' + [ Just percentamount + -- Pad enough for max width: "100% xxxx.xx KiB xxxx KiB/s" + , Just $ replicate (29 - length percentamount - length rate) ' ' , Just rate , estimatedcompletion ] where - percentoramount = case mtotalsize of - Just totalsize -> showPercentage 0 $ - percentage totalsize (min new totalsize) - Nothing -> roughSize' memoryUnits True 2 new + amount = roughSize' memoryUnits True 2 new + percentamount = case mtotalsize of + Just totalsize -> + let p = showPercentage 0 $ + percentage totalsize (min new totalsize) + in p ++ replicate (6 - length p) ' ' ++ amount + Nothing -> amount rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s" bytespersecond | duration == 0 = fromIntegral transferred @@ -377,5 +420,5 @@ bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) Just totalsize | bytespersecond > 0 -> Just $ fromDuration $ Duration $ - totalsize `div` bytespersecond + (totalsize - new) `div` bytespersecond _ -> Nothing diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 2ae9928..2f1766e 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -5,10 +5,22 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Misc where +module Utility.Misc ( + hGetContentsStrict, + readFileStrict, + separate, + firstLine, + firstLine', + segment, + segmentDelim, + massReplace, + hGetSomeString, + exitBool, + + prop_segment_regressionTest, +) where import System.IO import Control.Monad @@ -16,11 +28,8 @@ import Foreign import Data.Char import Data.List import System.Exit -#ifndef mingw32_HOST_OS -import System.Posix.Process (getAnyProcessStatus) -import Utility.Exception -#endif import Control.Applicative +import qualified Data.ByteString as S import Prelude {- A version of hgetContents that is not lazy. Ensures file is @@ -49,6 +58,11 @@ separate c l = unbreak $ break c l firstLine :: String -> String firstLine = takeWhile (/= '\n') +firstLine' :: S.ByteString -> S.ByteString +firstLine' = S.takeWhile (/= nl) + where + nl = fromIntegral (ord '\n') + {- Splits a list into segments that are delimited by items matching - a predicate. (The delimiters are not included in the segments.) - Segments may be empty. -} @@ -112,22 +126,6 @@ hGetSomeString h sz = do peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes len buf = mapM (peekElemOff buf) [0..pred len] -{- Reaps any zombie processes that may be hanging around. - - - - Warning: Not thread safe. Anything that was expecting to wait - - on a process and get back an exit status is going to be confused - - if this reap gets there first. -} -reapZombies :: IO () -#ifndef mingw32_HOST_OS -reapZombies = - -- throws an exception when there are no child processes - catchDefaultIO Nothing (getAnyProcessStatus False True) - >>= maybe (return ()) (const reapZombies) - -#else -reapZombies = return () -#endif - exitBool :: Bool -> IO a exitBool False = exitFailure exitBool True = exitSuccess diff --git a/Utility/Monad.hs b/Utility/Monad.hs index ac75104..abe06f3 100644 --- a/Utility/Monad.hs +++ b/Utility/Monad.hs @@ -7,7 +7,19 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Monad where +module Utility.Monad ( + firstM, + getM, + anyM, + allM, + untilTrue, + ifM, + (<||>), + (<&&>), + observe, + after, + noop, +) where import Data.Maybe import Control.Monad diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs index 47e9831..90c67ff 100644 --- a/Utility/PartialPrelude.hs +++ b/Utility/PartialPrelude.hs @@ -7,7 +7,18 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.PartialPrelude where +module Utility.PartialPrelude ( + Utility.PartialPrelude.read, + Utility.PartialPrelude.head, + Utility.PartialPrelude.tail, + Utility.PartialPrelude.init, + Utility.PartialPrelude.last, + Utility.PartialPrelude.readish, + Utility.PartialPrelude.headMaybe, + Utility.PartialPrelude.lastMaybe, + Utility.PartialPrelude.beginning, + Utility.PartialPrelude.end, +) where import qualified Data.Maybe @@ -38,11 +49,9 @@ last = Prelude.last {- Attempts to read a value from a String. - - - Ignores leading/trailing whitespace, and throws away any trailing - - text after the part that can be read. - - - - readMaybe is available in Text.Read in new versions of GHC, - - but that one requires the entire string to be consumed. + - Unlike Text.Read.readMaybe, this ignores some trailing text + - after the part that can be read. However, if the trailing text looks + - like another readable value, it fails. -} readish :: Read a => String -> Maybe a readish s = case reads s of diff --git a/Utility/Path.hs b/Utility/Path.hs index dc91ce5..ecc752c 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -5,10 +5,32 @@ - License: BSD-2-clause -} -{-# LANGUAGE PackageImports, CPP #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Path where +module Utility.Path ( + simplifyPath, + absPathFrom, + parentDir, + upFrom, + dirContains, + absPath, + relPathCwdToFile, + relPathDirToFile, + relPathDirToFileAbs, + segmentPaths, + runSegmentPaths, + relHome, + inPath, + searchPath, + dotfile, + sanitizeFilePath, + splitShortExtensions, + + prop_upFrom_basics, + prop_relPathDirToFile_basics, + prop_relPathDirToFile_regressionTest, +) where import System.FilePath import Data.List @@ -17,17 +39,11 @@ import Data.Char import Control.Applicative import Prelude -#ifdef mingw32_HOST_OS -import qualified System.FilePath.Posix as Posix -#else -import System.Posix.Files -import Utility.Exception -#endif - import Utility.Monad import Utility.UserInfo import Utility.Directory import Utility.Split +import Utility.FileSystemEncoding {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -97,7 +113,10 @@ prop_upFrom_basics dir - are all equivilant. -} dirContains :: FilePath -> FilePath -> Bool -dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b' +dirContains a b = a == b + || a' == b' + || (addTrailingPathSeparator a') `isPrefixOf` b' + || a' == "." && normalise ("." </> b') == b' where a' = norm a b' = norm b @@ -185,20 +204,21 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - we stop preserving ordering at that point. Presumably a user passing - that many paths in doesn't care too much about order of the later ones. -} -segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] +segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation segmentPaths (l:ls) new = found : segmentPaths ls rest where (found, rest) = if length ls < 100 - then partition (l `dirContains`) new - else break (\p -> not (l `dirContains` p)) new + then partition inl new + else break (not . inl) new + inl f = fromRawFilePath l `dirContains` fromRawFilePath f {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In - the case of git file list commands, that assumption tends to hold. -} -runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]] +runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]] runSegmentPaths a paths = segmentPaths paths <$> a paths {- Converts paths in the home directory to use ~/ -} @@ -247,50 +267,6 @@ dotfile file where f = takeFileName file -{- Converts a DOS style path to a msys2 style path. Only on Windows. - - Any trailing '\' is preserved as a trailing '/' - - - - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i - - - - The virtual filesystem contains: - - /c, /d, ... mount points for Windows drives - -} -toMSYS2Path :: FilePath -> FilePath -#ifndef mingw32_HOST_OS -toMSYS2Path = id -#else -toMSYS2Path p - | null drive = recombine parts - | otherwise = recombine $ "/" : driveletter drive : parts - where - (drive, p') = splitDrive p - parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') - recombine = fixtrailing . Posix.joinPath - fixtrailing s - | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s - | otherwise = s -#endif - -{- Maximum size to use for a file in a specified directory. - - - - Many systems have a 255 byte limit to the name of a file, - - so that's taken as the max if the system has a larger limit, or has no - - limit. - -} -fileNameLengthLimit :: FilePath -> IO Int -#ifdef mingw32_HOST_OS -fileNameLengthLimit _ = return 255 -#else -fileNameLengthLimit dir = do - -- getPathVar can fail due to statfs(2) overflow - l <- catchDefaultIO 0 $ - fromIntegral <$> getPathVar dir FileNameLimit - if l <= 0 - then return 255 - else return $ minimum [l, 255] -#endif - {- Given a string that we'd like to use as the basis for FilePath, but that - was provided by a third party and is not to be trusted, returns the closest - sane FilePath. diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs deleted file mode 100644 index 37253da..0000000 --- a/Utility/PosixFiles.hs +++ /dev/null @@ -1,42 +0,0 @@ -{- POSIX files (and compatablity wrappers). - - - - This is like System.PosixCompat.Files, but with a few fixes. - - - - Copyright 2014 Joey Hess <id@joeyh.name> - - - - License: BSD-2-clause - -} - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} - -module Utility.PosixFiles ( - module X, - rename -) where - -import System.PosixCompat.Files as X hiding (rename) - -#ifndef mingw32_HOST_OS -import System.Posix.Files (rename) -#else -import qualified System.Win32.File as Win32 -import qualified System.Win32.HardLink as Win32 -#endif - -{- System.PosixCompat.Files.rename on Windows calls renameFile, - - so cannot rename directories. - - - - Instead, use Win32 moveFile, which can. It needs to be told to overwrite - - any existing file. -} -#ifdef mingw32_HOST_OS -rename :: FilePath -> FilePath -> IO () -rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING -#endif - -{- System.PosixCompat.Files.createLink throws an error, but windows - - does support hard links. -} -#ifdef mingw32_HOST_OS -createLink :: FilePath -> FilePath -> IO () -createLink = Win32.createHardLink -#endif diff --git a/Utility/Process.hs b/Utility/Process.hs index 6d981cb..af3a5f4 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -24,11 +24,10 @@ module Utility.Process ( createProcessSuccess, createProcessChecked, createBackgroundProcess, - processTranscript, - processTranscript', withHandle, withIOHandles, withOEHandles, + withNullHandle, withQuietOutput, feedWithQuietOutput, createProcess, @@ -54,13 +53,6 @@ import System.Log.Logger import Control.Concurrent import qualified Control.Exception as E import Control.Monad -#ifndef mingw32_HOST_OS -import qualified System.Posix.IO -#else -import Control.Applicative -#endif -import Data.Maybe -import Prelude type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -170,68 +162,6 @@ createProcessChecked checker p a = do createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p --- | Runs a process, optionally feeding it some input, and --- returns a transcript combining its stdout and stderr, and --- whether it succeeded or failed. -processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript cmd opts = processTranscript' (proc cmd opts) - -processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) -processTranscript' cp input = do -#ifndef mingw32_HOST_OS -{- This implementation interleves stdout and stderr in exactly the order - - the process writes them. -} - (readf, writef) <- System.Posix.IO.createPipe - readh <- System.Posix.IO.fdToHandle readf - writeh <- System.Posix.IO.fdToHandle writef - p@(_, _, _, pid) <- createProcess $ cp - { std_in = if isJust input then CreatePipe else Inherit - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } - hClose writeh - - get <- mkreader readh - writeinput input p - transcript <- get - - ok <- checkSuccessProcess pid - return (transcript, ok) -#else -{- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ cp - { std_in = if isJust input then CreatePipe else Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } - - getout <- mkreader (stdoutHandle p) - geterr <- mkreader (stderrHandle p) - writeinput input p - transcript <- (++) <$> getout <*> geterr - - ok <- checkSuccessProcess pid - return (transcript, ok) -#endif - where - mkreader h = do - s <- hGetContents h - v <- newEmptyMVar - void $ forkIO $ do - void $ E.evaluate (length s) - putMVar v () - return $ do - takeMVar v - return s - - writeinput (Just s) p = do - let inh = stdinHandle p - unless (null s) $ do - hPutStr inh s - hFlush inh - hClose inh - writeinput Nothing _ = return () - -- | Runs a CreateProcessRunner, on a CreateProcess structure, that -- is adjusted to pipe only from/to a single StdHandle, and passes -- the resulting Handle to an action. @@ -248,13 +178,10 @@ withHandle h creator p a = creator p' $ a . select , std_out = Inherit , std_err = Inherit } - (select, p') - | h == StdinHandle = - (stdinHandle, base { std_in = CreatePipe }) - | h == StdoutHandle = - (stdoutHandle, base { std_out = CreatePipe }) - | h == StderrHandle = - (stderrHandle, base { std_err = CreatePipe }) + (select, p') = case h of + StdinHandle -> (stdinHandle, base { std_in = CreatePipe }) + StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe }) + StderrHandle -> (stderrHandle, base { std_err = CreatePipe }) -- | Like withHandle, but passes (stdin, stdout) handles to the action. withIOHandles @@ -284,13 +211,16 @@ withOEHandles creator p a = creator p' $ a . oeHandles , std_err = CreatePipe } +withNullHandle :: (Handle -> IO a) -> IO a +withNullHandle = withFile devNull WriteMode + -- | Forces the CreateProcessRunner to run quietly; -- both stdout and stderr are discarded. withQuietOutput :: CreateProcessRunner -> CreateProcess -> IO () -withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do +withQuietOutput creator p = withNullHandle $ \nullh -> do let p' = p { std_out = UseHandle nullh , std_err = UseHandle nullh @@ -316,7 +246,8 @@ devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null" #else -devNull = "NUL" +-- Use device namespace to prevent GHC from rewriting path +devNull = "\\\\.\\NUL" #endif -- | Extract a desired handle from createProcess's tuple. diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index e89d103..b0a39f3 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -6,7 +6,7 @@ -} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances, CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} module Utility.QuickCheck ( module X @@ -15,29 +15,24 @@ module Utility.QuickCheck import Test.QuickCheck as X import Data.Time.Clock.POSIX +import Data.Ratio import System.Posix.Types -#if ! MIN_VERSION_QuickCheck(2,8,2) -import qualified Data.Map as M -import qualified Data.Set as S -#endif -import Control.Applicative +import Data.List.NonEmpty (NonEmpty(..)) import Prelude -#if ! MIN_VERSION_QuickCheck(2,8,2) -instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where - arbitrary = M.fromList <$> arbitrary - -instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where - arbitrary = S.fromList <$> arbitrary -#endif - -{- Times before the epoch are excluded. -} +{- Times before the epoch are excluded. Half with decimal and half without. -} instance Arbitrary POSIXTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral + arbitrary = do + n <- nonNegative arbitrarySizedBoundedIntegral :: Gen Int + d <- nonNegative arbitrarySizedIntegral + withd <- arbitrary + return $ if withd + then fromIntegral n + fromRational (1 % max d 1) + else fromIntegral n {- Pids are never negative, or 0. -} instance Arbitrary ProcessID where - arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) + arbitrary = positive arbitrarySizedBoundedIntegral {- Inodes are never negative. -} instance Arbitrary FileID where @@ -47,6 +42,9 @@ instance Arbitrary FileID where instance Arbitrary FileOffset where arbitrary = nonNegative arbitrarySizedIntegral +instance Arbitrary l => Arbitrary (NonEmpty l) where + arbitrary = (:|) <$> arbitrary <*> arbitrary + nonNegative :: (Num a, Ord a) => Gen a -> Gen a nonNegative g = g `suchThat` (>= 0) diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index f190b40..c6881b7 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -7,12 +7,26 @@ {-# LANGUAGE CPP #-} -module Utility.Rsync where +module Utility.Rsync ( + rsyncShell, + rsyncServerSend, + rsyncServerReceive, + rsyncUseDestinationPermissions, + rsync, + rsyncUrlIsShell, + rsyncUrlIsPath, + rsyncProgress, + filterRsyncSafeOptions, +) where import Common import Utility.Metered import Utility.Tuple +#ifdef mingw32_HOST_OS +import qualified System.FilePath.Posix as Posix +#endif + import Data.Char import System.Console.GetOpt @@ -99,7 +113,16 @@ rsyncUrlIsPath s - The params must enable rsync's --progress mode for this to work. -} rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool -rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup +rsyncProgress oh meter ps = + commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case + Just ExitSuccess -> return True + Just (ExitFailure exitcode) -> do + when (exitcode /= 1) $ + hPutStrLn stderr $ "rsync exited " ++ show exitcode + return False + Nothing -> do + hPutStrLn stderr $ "unable to run rsync" + return False {- Strategy: Look for chunks prefixed with \r (rsync writes a \r before - the first progress output, and each thereafter). The first number @@ -139,3 +162,27 @@ filterRsyncSafeOptions = fst3 . getOpt Permute [ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ] where reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) "" + +{- Converts a DOS style path to a msys2 style path. Only on Windows. + - Any trailing '\' is preserved as a trailing '/' + - + - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i + - + - The virtual filesystem contains: + - /c, /d, ... mount points for Windows drives + -} +#ifdef mingw32_HOST_OS +toMSYS2Path :: FilePath -> FilePath +toMSYS2Path p + | null drive = recombine parts + | otherwise = recombine $ "/" : driveletter drive : parts + where + (drive, p') = splitDrive p + parts = splitDirectories p' + driveletter = map toLower . takeWhile (/= ':') + recombine = fixtrailing . Posix.joinPath + fixtrailing s + | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s + | otherwise = s +#endif + diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index eb34d3d..19d5f20 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -7,7 +7,23 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.SafeCommand where +module Utility.SafeCommand ( + CommandParam(..), + toCommand, + boolSystem, + boolSystem', + boolSystemEnv, + safeSystem, + safeSystem', + safeSystemEnv, + shellWrap, + shellEscape, + shellUnEscape, + segmentXargsOrdered, + segmentXargsUnordered, + prop_isomorphic_shellEscape, + prop_isomorphic_shellEscape_multiword, +) where import System.Exit import Utility.Process @@ -27,19 +43,21 @@ data CommandParam -- | Used to pass a list of CommandParams to a function that runs -- a command and expects Strings. -} toCommand :: [CommandParam] -> [String] -toCommand = map unwrap +toCommand = map toCommand' + +toCommand' :: CommandParam -> String +toCommand' (Param s) = s +-- Files that start with a non-alphanumeric that is not a path +-- separator are modified to avoid the command interpreting them as +-- options or other special constructs. +toCommand' (File s@(h:_)) + | isAlphaNum h || h `elem` pathseps = s + | otherwise = "./" ++ s where - unwrap (Param s) = s - -- Files that start with a non-alphanumeric that is not a path - -- separator are modified to avoid the command interpreting them as - -- options or other special constructs. - unwrap (File s@(h:_)) - | isAlphaNum h || h `elem` pathseps = s - | otherwise = "./" ++ s - unwrap (File s) = s -- '/' is explicitly included because it's an alternative -- path separator on Windows. pathseps = pathSeparator:"./" +toCommand' (File s) = s -- | Run a system command, and returns True or False if it succeeded or failed. -- diff --git a/Utility/Split.hs b/Utility/Split.hs index decfe7d..028218e 100644 --- a/Utility/Split.hs +++ b/Utility/Split.hs @@ -7,7 +7,12 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Split where +module Utility.Split ( + split, + splitc, + replace, + dropFromEnd, +) where import Data.List (intercalate) import Data.List.Split (splitOn) @@ -28,3 +33,7 @@ splitc c s = case break (== c) s of -- | same as Data.List.Utils.replace replace :: Eq a => [a] -> [a] -> [a] -> [a] replace old new = intercalate new . split old + +-- | Only traverses the list once while dropping the last n items. +dropFromEnd :: Int -> [a] -> [a] +dropFromEnd n l = zipWith const l (drop n l) diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index da05e99..ef69ead 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -8,7 +8,14 @@ {-# LANGUAGE CPP #-} -module Utility.ThreadScheduler where +module Utility.ThreadScheduler ( + Seconds(..), + Microseconds, + runEvery, + threadDelaySeconds, + waitForTermination, + oneSecond, +) where import Control.Monad import Control.Concurrent @@ -18,10 +25,8 @@ import System.Posix.IO #endif #ifndef mingw32_HOST_OS import System.Posix.Signals -#ifndef __ANDROID__ import System.Posix.Terminal #endif -#endif newtype Seconds = Seconds { fromSeconds :: Int } deriving (Eq, Ord, Show) @@ -63,10 +68,8 @@ waitForTermination = do let check sig = void $ installHandler sig (CatchOnce $ putMVar lock ()) Nothing check softwareTermination -#ifndef __ANDROID__ whenM (queryTerminal stdInput) $ check keyboardSignal -#endif takeMVar lock #endif diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 7255c14..6ee592b 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,4 +1,4 @@ -{- Temporary files and directories. +{- Temporary files. - - Copyright 2010-2013 Joey Hess <id@joeyh.name> - @@ -8,17 +8,19 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Tmp where +module Utility.Tmp ( + Template, + viaTmp, + withTmpFile, + withTmpFileIn, + relatedTemplate, +) where import System.IO -import Control.Monad.IfElse import System.FilePath import System.Directory import Control.Monad.IO.Class import System.PosixCompat.Files -#ifndef mingw32_HOST_OS -import System.Posix.Temp (mkdtemp) -#endif import Utility.Exception import Utility.FileSystemEncoding @@ -32,7 +34,7 @@ viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v - viaTmp a file content = bracketIO setup cleanup use where (dir, base) = splitFileName file - template = base ++ ".tmp" + template = relatedTemplate (base ++ ".tmp") setup = do createDirectoryIfMissing True dir openTempFile dir template @@ -62,51 +64,6 @@ withTmpFileIn tmpdir template a = bracket create remove use catchBoolIO (removeFile name >> return True) use (name, h) = a name h -{- Runs an action with a tmp directory located within the system's tmp - - directory (or within "." if there is none), then removes the tmp - - directory and all its contents. -} -withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a -withTmpDir template a = do - topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory -#ifndef mingw32_HOST_OS - -- Use mkdtemp to create a temp directory securely in /tmp. - bracket - (liftIO $ mkdtemp $ topleveltmpdir </> template) - removeTmpDir - a -#else - withTmpDirIn topleveltmpdir template a -#endif - -{- Runs an action with a tmp directory located within a specified directory, - - then removes the tmp directory and all its contents. -} -withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a -withTmpDirIn tmpdir template = bracketIO create removeTmpDir - where - create = do - createDirectoryIfMissing True tmpdir - makenewdir (tmpdir </> template) (0 :: Int) - makenewdir t n = do - let dir = t ++ "." ++ show n - catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do - createDirectory dir - return dir - -{- Deletes the entire contents of the the temporary directory, if it - - exists. -} -removeTmpDir :: MonadIO m => FilePath -> m () -removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do -#if mingw32_HOST_OS - -- Windows will often refuse to delete a file - -- after a process has just written to it and exited. - -- Because it's crap, presumably. So, ignore failure - -- to delete the temp directory. - _ <- tryIO $ removeDirectoryRecursive tmpdir - return () -#else - removeDirectoryRecursive tmpdir -#endif - {- It's not safe to use a FilePath of an existing file as the template - for openTempFile, because if the FilePath is really long, the tmpfile - will be longer, and may exceed the maximum filename length. diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs new file mode 100644 index 0000000..c68ef86 --- /dev/null +++ b/Utility/Tmp/Dir.hs @@ -0,0 +1,70 @@ +{- Temporary directories + - + - Copyright 2010-2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Tmp.Dir ( + withTmpDir, + withTmpDirIn, +) where + +import Control.Monad.IfElse +import System.FilePath +import System.Directory +import Control.Monad.IO.Class +#ifndef mingw32_HOST_OS +import System.Posix.Temp (mkdtemp) +#endif + +import Utility.Exception +import Utility.Tmp (Template) + +{- Runs an action with a tmp directory located within the system's tmp + - directory (or within "." if there is none), then removes the tmp + - directory and all its contents. -} +withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a +withTmpDir template a = do + topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory +#ifndef mingw32_HOST_OS + -- Use mkdtemp to create a temp directory securely in /tmp. + bracket + (liftIO $ mkdtemp $ topleveltmpdir </> template) + removeTmpDir + a +#else + withTmpDirIn topleveltmpdir template a +#endif + +{- Runs an action with a tmp directory located within a specified directory, + - then removes the tmp directory and all its contents. -} +withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a +withTmpDirIn tmpdir template = bracketIO create removeTmpDir + where + create = do + createDirectoryIfMissing True tmpdir + makenewdir (tmpdir </> template) (0 :: Int) + makenewdir t n = do + let dir = t ++ "." ++ show n + catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do + createDirectory dir + return dir + +{- Deletes the entire contents of the the temporary directory, if it + - exists. -} +removeTmpDir :: MonadIO m => FilePath -> m () +removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do +#if mingw32_HOST_OS + -- Windows will often refuse to delete a file + -- after a process has just written to it and exited. + -- Because it's crap, presumably. So, ignore failure + -- to delete the temp directory. + _ <- tryIO $ removeDirectoryRecursive tmpdir + return () +#else + removeDirectoryRecursive tmpdir +#endif diff --git a/Utility/Tuple.hs b/Utility/Tuple.hs index 25c6e8f..9638bcc 100644 --- a/Utility/Tuple.hs +++ b/Utility/Tuple.hs @@ -5,7 +5,11 @@ - License: BSD-2-clause -} -module Utility.Tuple where +module Utility.Tuple ( + fst3, + snd3, + thd3, +) where fst3 :: (a,b,c) -> a fst3 (a,_,_) = a diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index d504fa5..17ce8db 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -14,7 +14,7 @@ module Utility.UserInfo ( myUserGecos, ) where -import Utility.Env +import Utility.Env.Basic import Utility.Exception #ifndef mingw32_HOST_OS import Utility.Data @@ -47,8 +47,8 @@ myUserName = myVal env userName #endif myUserGecos :: IO (Maybe String) --- userGecos crashes on Android and is not available on Windows. -#if defined(__ANDROID__) || defined(mingw32_HOST_OS) +-- userGecos is not available on Windows. +#if defined(mingw32_HOST_OS) myUserGecos = return Nothing #else myUserGecos = eitherToMaybe <$> myVal [] userGecos @@ -57,10 +57,13 @@ myUserGecos = eitherToMaybe <$> myVal [] userGecos myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars where + go [] = either (const $ envnotset) (Right . extract) <$> get + go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v #ifndef mingw32_HOST_OS - go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) + -- This may throw an exception if the system doesn't have a + -- passwd file etc; don't let it crash. + get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID #else - go [] = return $ either Left (Right . extract) $ - Left ("environment not set: " ++ show envvars) + get = return envnotset #endif - go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v + envnotset = Left ("environment not set: " ++ show envvars) diff --git a/debian/copyright b/debian/copyright index 33f85b4..dc5f40a 100644..120000 --- a/debian/copyright +++ b/debian/copyright @@ -1,35 +1 @@ -Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ -Source: native package - -Files: * -Copyright: © 2013 Joey Hess <joey@kitenet.net> -License: GPL-3+ - The full text of version 3 of the GPL is distributed as doc/GPL in - this package's source, or in /usr/share/common-licenses/GPL-3 on - Debian systems. - -Files: Utility/* -Copyright: 2012-2014 Joey Hess <joey@kitenet.net> -License: BSD-2-clause - -License: BSD-2-clause - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - . - THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. +../COPYRIGHT
\ No newline at end of file diff --git a/git-repair.cabal b/git-repair.cabal index cff316f..f273cb3 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,12 +1,12 @@ Name: git-repair -Version: 1.20170626 +Version: 1.20200102 Cabal-Version: >= 1.8 -License: GPL +License: AGPL-3 Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess Stability: Stable Copyright: 2013 Joey Hess -License-File: GPL +License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/ Category: Utility @@ -25,13 +25,10 @@ Extra-Source-Files: TODO git-repair.1 -Flag network-uri - Description: Get Network.URI from the network-uri package - Default: True - custom-setup - Setup-Depends: base (>= 4.5), hslogger, split, unix-compat, process, - unix, filepath, exceptions, bytestring, directory, IfElse, data-default, + Setup-Depends: base (>= 4.11.1.0 && < 5.0), + hslogger, split, unix-compat, process, unix, filepath, + exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal source-repository head @@ -41,21 +38,19 @@ source-repository head Executable git-repair Main-Is: git-repair.hs GHC-Options: -threaded -Wall -fno-warn-tabs + Extensions: LambdaCase Build-Depends: split, hslogger, directory, filepath, containers, mtl, - unix-compat, bytestring, exceptions (>= 0.6), transformers, - base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck, - utf8-string, async, optparse-applicative (>= 0.10.0), - data-default - - if flag(network-uri) - Build-Depends: network-uri (>= 2.6), network (>= 2.6) - else - Build-Depends: network (< 2.6), network (>= 2.0) + unix-compat (>= 0.5), bytestring, exceptions (>= 0.6), transformers, + base (>= 4.11.1.0 && < 5.0), IfElse, text, process, time, QuickCheck, + utf8-string, async, optparse-applicative (>= 0.14.1), + data-default, deepseq, attoparsec, + network-uri (>= 2.6), network (>= 2.6), + filepath-bytestring (>= 1.4.2.1.0) if (os(windows)) Build-Depends: setenv else - Build-Depends: unix + Build-Depends: unix (>= 2.7.2) Other-Modules: BuildInfo @@ -76,6 +71,7 @@ Executable git-repair Git.FilePath Git.Filename Git.Fsck + Git.HashObject Git.Index Git.LsFiles Git.LsTree @@ -89,6 +85,7 @@ Executable git-repair Git.UpdateIndex Git.Url Git.Version + Utility.Attoparsec Utility.Applicative Utility.Batch Utility.CoProcess @@ -97,6 +94,8 @@ Executable git-repair Utility.Directory Utility.DottedVersion Utility.Env + Utility.Env.Basic + Utility.Env.Set Utility.Exception Utility.FileMode Utility.FileSize @@ -110,7 +109,6 @@ Executable git-repair Utility.PartialPrelude Utility.Path Utility.Percentage - Utility.PosixFiles Utility.Process Utility.Process.Shim Utility.QuickCheck @@ -120,5 +118,6 @@ Executable git-repair Utility.SystemDirectory Utility.ThreadScheduler Utility.Tmp + Utility.Tmp.Dir Utility.Tuple Utility.UserInfo diff --git a/git-repair.hs b/git-repair.hs index 4076c15..ce4d16a 100644 --- a/git-repair.hs +++ b/git-repair.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} import Options.Applicative @@ -14,8 +14,7 @@ import qualified Git.Config import qualified Git.Construct import qualified Git.Destroyer import qualified Git.Fsck -import Utility.Tmp -import Utility.FileSystemEncoding +import Utility.Tmp.Dir data Settings = Settings { forced :: Bool |