diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2020-01-02 18:07:10 +0000 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2020-01-02 18:07:10 +0000 |
| commit | 1092316ba04116d7ae1d4cdf347804feacef768a (patch) | |
| tree | fbc819794d4202a4ac778f0f6be57eedef7518dd | |
| parent | d1e0531dd8e8b842349421a898b74b212d2157e8 (diff) | |
| parent | 50a5a7b101cc9c30a5a04b4c20cbf7f99fcab0ef (diff) | |
| download | git-repair-1092316ba04116d7ae1d4cdf347804feacef768a.tar.gz | |
Merge tag '1.20200102'
tagging package git-repair version 1.20200102
85 files changed, 3426 insertions, 1895 deletions
@@ -1,3 +1,4 @@ -Build/SysConfig.hs +Build/SysConfig tags git-repair +dist diff --git a/Build/Configure.hs b/Build/Configure.hs index e488ee1..1a3527f 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -1,10 +1,13 @@ -{- Checks system configuration and generates SysConfig.hs. -} +{- Checks system configuration and generates SysConfig. -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} 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 @@ -13,7 +16,7 @@ import Git.Version tests :: [TestCase] tests = [ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion) - , TestCase "git" $ requireCmd "git" "git --version >/dev/null" + , TestCase "git" $ testCmd "git" "git --version >/dev/null" , TestCase "git version" getGitVersion ] @@ -23,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/Build/TestConfig.hs b/Build/TestConfig.hs index e55641f..2f7213f 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -1,14 +1,16 @@ -{- Tests the system and generates Build.SysConfig.hs. -} +{- Tests the system and generates SysConfig. -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} module Build.TestConfig where import Utility.Path import Utility.Monad import Utility.SafeCommand +import Utility.Directory import System.IO import System.FilePath -import System.Directory type ConfigKey = String data ConfigValue = @@ -40,12 +42,11 @@ instance Show Config where valuetype (MaybeBoolConfig _) = "Maybe Bool" writeSysConfig :: [Config] -> IO () -writeSysConfig config = writeFile "Build/SysConfig.hs" body +writeSysConfig config = writeFile "Build/SysConfig" body where body = unlines $ header ++ map show config ++ footer header = [ "{- Automatically generated. -}" - , "module Build.SysConfig where" , "" ] footer = [] @@ -59,18 +60,6 @@ runTests (TestCase tname t : ts) = do rest <- runTests ts return $ c:rest -{- Tests that a command is available, aborting if not. -} -requireCmd :: ConfigKey -> String -> Test -requireCmd k cmdline = do - ret <- testCmd k cmdline - handle ret - where - handle r@(Config _ (BoolConfig True)) = return r - handle r = do - testEnd r - error $ "** the " ++ c ++ " command is required" - c = head $ words cmdline - {- Checks if a command is available by running a command line. -} testCmd :: ConfigKey -> String -> Test testCmd k cmdline = do diff --git a/Build/Version.hs b/Build/Version.hs index da9d1bb..d39a0fe 100644 --- a/Build/Version.hs +++ b/Build/Version.hs @@ -1,24 +1,26 @@ {- Package version determination, for configure script. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Build.Version where -import Data.Maybe -import Control.Applicative import Data.List import System.Environment -import System.Directory import Data.Char import System.Process +import Control.Applicative +import Prelude import Utility.Monad import Utility.Exception +import Utility.Directory type Version = String {- Set when making an official release. (Distribution vendors should set - this too.) -} isReleaseBuild :: IO Bool -isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD") +isReleaseBuild = (== Just "1") <$> catchMaybeIO (getEnv "RELEASE_BUILD") {- Version is usually based on the major version from the changelog, - plus the date of the last commit, plus the git rev of that commit. @@ -44,7 +46,7 @@ getVersion = do getChangelogVersion :: IO Version getChangelogVersion = do - changelog <- readFile "debian/changelog" + changelog <- readFile "CHANGELOG" let verline = takeWhile (/= '\n') changelog return $ middle (words verline !! 1) where diff --git a/Build/make-sdist.sh b/Build/make-sdist.sh deleted file mode 100755 index d4dbdb9..0000000 --- a/Build/make-sdist.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh -# -# Workaround for `cabal sdist` requiring all included files to be listed -# in .cabal. - -# Create target directory -sdist_dir=git-repair-$(grep '^Version:' git-repair.cabal | sed -re 's/Version: *//') -mkdir --parents dist/$sdist_dir - -find . \( -name .git -or -name dist -or -name cabal-dev \) -prune \ - -or -not -name \\*.orig -not -type d -print \ -| perl -ne "print unless length >= 100 - length q{$sdist_dir}" \ -| xargs cp --parents --target-directory dist/$sdist_dir - -cd dist -tar --format=ustar -caf $sdist_dir.tar.gz $sdist_dir - -# Check that tarball can be unpacked by cabal. -# It's picky about tar longlinks etc. -rm -rf $sdist_dir -cabal unpack $sdist_dir.tar.gz diff --git a/BuildInfo.hs b/BuildInfo.hs new file mode 100644 index 0000000..e54bdca --- /dev/null +++ b/BuildInfo.hs @@ -0,0 +1,12 @@ +{- build info + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module BuildInfo where + +#include "Build/SysConfig" diff --git a/CHANGELOG b/CHANGELOG index d526672..50f9332 120000..100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1 +1,142 @@ -debian/changelog
\ No newline at end of file +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, 02 Jan 2020 12:39:13 -0400 + +git-repair (1.20170626) unstable; urgency=medium + + * Merge from git-annex. + * Removes dependency on MissingH, adding a dependency on split instead. + * Fixes build with directory-1.3. + + -- Joey Hess <id@joeyh.name> Mon, 26 Jun 2017 12:15:29 -0400 + +git-repair (1.20161118) unstable; urgency=medium + + * Fix build with recent versions of cabal and ghc. + + -- Joey Hess <id@joeyh.name> Fri, 18 Nov 2016 12:59:07 -0400 + +git-repair (1.20161111) unstable; urgency=medium + + * git-repair.cabal: Add Setup-Depends. + * Updated cabal file explictly lists source files. The tarball + on hackage will include only the files needed for cabal install; + it is NOT the full git-repair source tree. + * debian/changelog: Converted to symlinks to CHANGELOG. + * Merge from git-annex. + * Makefile: Support building with stack as well as cabal. + * Makefile: The CABAL variable has been renamed to BUILDER. + + -- Joey Hess <id@joeyh.name> Fri, 11 Nov 2016 14:56:14 -0400 + +git-repair (1.20151215) unstable; urgency=medium + + * Fix insecure temporary permissions and potential denial of + service attack when creating temp dirs. Closes: #807341 + * Merge from git-annex. + + -- Joey Hess <id@joeyh.name> Tue, 15 Dec 2015 20:47:59 -0400 + +git-repair (1.20150106) unstable; urgency=medium + + * Debian package is now maintained by Richard Hartmann. + * Fix build with process 1.2.1.0. + * Merge from git-annex. + + -- Joey Hess <id@joeyh.name> Tue, 06 Jan 2015 19:09:23 -0400 + +git-repair (1.20141027) unstable; urgency=medium + + * Adjust cabal file to support network-uri split. + * Merge Build/ from git-annex, including removing a use of deprecated + System.Cmd. + + -- Joey Hess <joeyh@debian.org> Mon, 27 Oct 2014 11:09:56 -0400 + +git-repair (1.20141026) unstable; urgency=medium + + * Prevent auto gc from happening when fetching from a remote. + * Merge from git-annex. + + -- Joey Hess <joeyh@debian.org> Sun, 26 Oct 2014 13:37:30 -0400 + +git-repair (1.20140914) unstable; urgency=medium + + * Update to build with optparse-applicative 0.10. Closes: #761552 + + -- Joey Hess <joeyh@debian.org> Sun, 14 Sep 2014 12:48:27 -0400 + +git-repair (1.20140815) unstable; urgency=medium + + * Removing bad objects could leave fsck finding no more unreachable objects, + but some branches no longer accessible. Fix this, including support for + fixing up repositories that were incompletely repaired before. + * Merge from git-annex. + + -- Joey Hess <joeyh@debian.org> Fri, 15 Aug 2014 13:49:09 -0400 + +git-repair (1.20140423) unstable; urgency=medium + + * Improve memory usage when git fsck finds a great many broken objects. + * Merge from git-annex. + + -- Joey Hess <joeyh@debian.org> Wed, 23 Apr 2014 14:01:30 -0400 + +git-repair (1.20140227) unstable; urgency=medium + + * Optimise unpacking of pack files, and avoid repeated error + messages about corrupt pack files. + * Add swapping 2 files test case. + + -- Joey Hess <joeyh@debian.org> Thu, 27 Feb 2014 11:56:27 -0400 + +git-repair (1.20140115) unstable; urgency=medium + + * Support old git versions from before git fsck --no-dangling was + implemented. + * Fix bug in packed refs file exploding code that caused a .gitrefs + directory to be created instead of .git/refs + * Check git version at run time. + + -- Joey Hess <joeyh@debian.org> Wed, 15 Jan 2014 16:53:30 -0400 + +git-repair (1.20131213) unstable; urgency=low + + * Improve repair of index files in some situations. + + -- Joey Hess <joeyh@debian.org> Fri, 13 Dec 2013 14:51:51 -0400 + +git-repair (1.20131203) unstable; urgency=low + + * Fix build deps. Closes: #731179 + + -- Joey Hess <joeyh@debian.org> Tue, 03 Dec 2013 15:02:21 -0400 + +git-repair (1.20131122) unstable; urgency=low + + * Added test mode, which can be used to randomly corrupt test + repositories, in reproducible ways, which allows easy + corruption-driven-development. + * Improve repair code in the case where the index file is corrupt, + and this hides other problems. + * Write a dummy .git/HEAD if the file is missing or corrupt, as + git otherwise will not treat the repository as a git repo. + * Improve fsck code to find badly corrupted objects that crash git fsck + before it can complain about them. + * Fixed crashes on bad file encodings. + * Can now run 10000 tests (git-repair --test -n 10000 --force) + with 0 failures. + + -- Joey Hess <joeyh@debian.org> Fri, 22 Nov 2013 11:16:03 -0400 + +git-repair (1.20131118) unstable; urgency=low + + * First release + + -- Joey Hess <joeyh@debian.org> Mon, 18 Nov 2013 13:38:12 -0400 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/>. @@ -5,12 +5,12 @@ module Common (module X) where import Control.Monad as X import Control.Monad.IfElse as X import Control.Applicative as X -import "mtl" Control.Monad.State.Strict as X (liftIO) +import Control.Monad.IO.Class as X (liftIO) import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) -import Data.String.Utils as X hiding (join) import Data.Monoid as X +import Data.Default as X import System.FilePath as X import System.IO as X hiding (FilePath) @@ -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 hiding (getFileSize) import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X -import Utility.FileSystemEncoding 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 #-} @@ -26,8 +26,10 @@ module Git ( repoDescribe, repoLocation, repoPath, + repoWorkTree, localGitDir, attributes, + attributesLocal, hookPath, assertLocal, adjustPath, @@ -49,31 +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 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" @@ -125,14 +131,18 @@ assertLocal repo action {- Path to a repository's gitattributes file. -} attributes :: Repo -> FilePath attributes repo - | repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes" - | otherwise = repoPath repo ++ "/.gitattributes" + | repoIsLocalBare repo = attributesLocal repo + | otherwise = fromRawFilePath (repoPath repo) </> ".gitattributes" + +attributesLocal :: Repo -> FilePath +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 @@ -148,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 a2225dc..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 @@ -13,56 +14,69 @@ import Common import Git 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 Git.Ref) +current :: Repo -> IO (Maybe Branch) current r = do v <- currentUnsafe r 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 Git.Ref) -currentUnsafe r = parse . firstLine +currentUnsafe :: Repo -> IO (Maybe Branch) +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. -} changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False - | otherwise = not . null <$> diffs + | otherwise = not . null + <$> changed' origbranch newbranch [Param "-n1"] repo + where + +changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String +changed' origbranch newbranch extraps repo = + decodeBS <$> pipeReadStrict ps repo where - diffs = pipeReadStrict + ps = [ Param "log" , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) - , Param "-n1" , Param "--pretty=%H" - ] repo - + ] ++ extraps + +{- Lists commits that are in the second branch and not in the first branch. -} +changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] +changedCommits origbranch newbranch extraps repo = + catMaybes . map extractSha . lines + <$> changed' origbranch newbranch extraps repo + {- Check if it's possible to fast-forward from the old - ref to the new ref. - - 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 @@ -90,7 +104,7 @@ fastForward branch (first:rest) repo = where no_ff = return False do_ff to = do - update branch to repo + update' branch to repo return True findbest c [] = return $ Just c findbest c (r:rs) @@ -104,27 +118,36 @@ fastForward branch (first:rest) repo = (False, True) -> findbest c rs -- worse (False, False) -> findbest c rs -- same -{- The user may have set commit.gpgsign, indending all their manual +{- The user may have set commit.gpgsign, intending all their manual - commits to be signed. But signing automatic/background commits could - easily lead to unwanted gpg prompts or failures. -} data CommitMode = ManualCommit | AutomaticCommit deriving (Eq) +{- 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, + - but others need -S to be passed to enable gpg signing of manual commits. -} +applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam] +applyCommitModeForCommitTree commitmode ps r + | commitmode == ManualCommit = + case Git.Config.getMaybe "commit.gpgsign" r of + Just s | Git.Config.isTrueFalse' s == Just True -> + Param "-S":ps + _ -> ps' + | otherwise = ps' + where + ps' = applyCommitMode commitmode ps + {- Commit via the usual git command. -} commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool commitCommand = commitCommand' runBool -{- Commit will fail when the tree is clean. This suppresses that error. -} -commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO () -commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps - commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a commitCommand' runner commitmode ps = runner $ Param "commit" : applyCommitMode commitmode ps @@ -141,39 +164,54 @@ 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 <- getSha "commit-tree" $ - pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo - update branch sha repo + sha <- commitTree commitmode message parentrefs tree repo + update' branch sha repo return $ Just sha , return Nothing ) where - ps = applyCommitMode commitmode $ - map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs cancommit tree | allowempty = return True | otherwise = case parentrefs of [p] -> maybe False (tree /=) <$> Git.Ref.tree p repo _ -> return True - sendmsg = Just $ flip hPutStr message commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha commitAlways commitmode message branch parentrefs repo = fromJust <$> commit commitmode True message branch parentrefs repo +commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha +commitTree commitmode message parentrefs tree repo = + getSha "commit-tree" $ + pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) + sendmsg repo + where + sendmsg = Just $ flip hPutStr message + ps = applyCommitModeForCommitTree commitmode parentparams repo + parentparams = map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs + {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String forcePush b = "+" ++ b -{- Updates a branch (or other ref) to a new Sha. -} -update :: Branch -> Sha -> Repo -> IO () -update branch sha = run +{- Updates a branch (or other ref) to a new Sha or branch Ref. -} +update :: String -> Branch -> Ref -> Repo -> IO () +update message branch r = run + [ Param "update-ref" + , Param "-m" + , Param message + , Param $ fromRef branch + , Param $ fromRef r + ] + +update' :: Branch -> Ref -> Repo -> IO () +update' branch r = run [ Param "update-ref" , Param $ fromRef branch - , Param $ fromRef sha + , Param $ fromRef r ] {- Checks out a branch, creating it if necessary. -} diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs index 50e4a3a..f94a892 100644 --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -2,20 +2,20 @@ - - 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 import Git.Version -import qualified Build.SysConfig +import qualified BuildInfo {- Using the version it was configured for avoids running git to check its - version, at the cost that upgrading git won't be noticed. - This is only acceptable because it's rare that git's version influences - code's behavior. -} buildVersion :: GitVersion -buildVersion = normalize Build.SysConfig.gitversion +buildVersion = normalize BuildInfo.gitversion older :: String -> Bool older n = buildVersion < normalize n diff --git a/Git/CatFile.hs b/Git/CatFile.hs index c63a064..6402001 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,8 +1,8 @@ {- git cat-file interface - - - 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. -} module Git.CatFile ( @@ -13,49 +13,67 @@ module Git.CatFile ( catFile, catFileDetails, catTree, + catCommit, catObject, catObjectDetails, + catObjectMetaData, ) where import System.IO import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.Tuple.Utils +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.Map as M +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.Tuple -data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo +data CatFileHandle = CatFileHandle + { catFileProcess :: CoProcess.CoProcessHandle + , checkFileProcess :: CoProcess.CoProcessHandle + , gitRepo :: Repo + } catFileStart :: Repo -> IO CatFileHandle catFileStart = catFileStart' True catFileStart' :: Bool -> Repo -> IO CatFileHandle -catFileStart' restartable repo = do - coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable +catFileStart' restartable repo = CatFileHandle + <$> startp "--batch" + <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + <*> pure repo + where + startp p = gitCoProcessStart restartable [ Param "cat-file" - , Param "--batch" + , Param p ] repo - return $ CatFileHandle coprocess repo catFileStop :: CatFileHandle -> IO () -catFileStop (CatFileHandle p _) = CoProcess.stop p +catFileStop h = do + CoProcess.stop (catFileProcess h) + 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. -} @@ -63,31 +81,118 @@ 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 (CatFileHandle hdl _) object = CoProcess.query hdl send receive +catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do + header <- hGetLine from + case parseResp object header of + Just (ParsedResp sha size objtype) -> do + content <- S.hGet from (fromIntegral size) + eatchar '\n' from + return $ Just (L.fromChunks [content], sha, objtype) + Just DNE -> return Nothing + Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) where - query = fromRef object - send to = hPutStrLn to query - receive from = do - header <- hGetLine from - case words header of - [sha, objtype, size] - | length sha == shaSize -> - case (readObjectType objtype, reads size) of - (Just t, [(bytes, "")]) -> readcontent t bytes from sha - _ -> dne - | otherwise -> dne - _ - | header == fromRef object ++ " missing" -> dne - | otherwise -> error $ "unknown response from git cat-file " ++ show (header, query) - readcontent objtype bytes from sha = do - content <- S.hGet from bytes - eatchar '\n' from - return $ Just (L.fromChunks [content], Ref sha, objtype) - dne = return Nothing eatchar expected 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 (Sha, FileSize, ObjectType)) +catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do + resp <- hGetLine from + case parseResp object resp of + 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 FileSize ObjectType | DNE + +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 s + s = fromRef object + +parseResp :: Ref -> String -> Maybe ParsedResp +parseResp object l + | " missing" `isSuffixOf` l -- less expensive than full check + && l == fromRef object ++ " missing" = Just DNE + | otherwise = case words l of + [sha, objtype, size] + | length sha == shaSize -> + 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)] @@ -104,10 +209,51 @@ catTree h treeref = go <$> catObjectDetails h treeref (dropsha rest) -- these 20 bytes after the NUL hold the file's sha - -- TODO: convert from raw form to regular sha 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 + +catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) +catCommit h commitref = go <$> catObjectDetails h commitref + where + go (Just (b, _, CommitObject)) = parseCommit b + go _ = Nothing + +parseCommit :: L.ByteString -> Maybe Commit +parseCommit b = Commit + <$> (extractSha . L8.unpack =<< field "tree") + <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent")) + <*> (parsemetadata <$> field "author") + <*> (parsemetadata <$> field "committer") + <*> Just (L8.unpack $ L.intercalate (L.singleton nl) message) + where + field n = headMaybe =<< fields n + fields n = M.lookup (fromString n) fieldmap + fieldmap = M.fromListWith (++) ((map breakfield) header) + breakfield l = + let (k, sp_v) = L.break (== sp) l + in (k, [L.drop 1 sp_v]) + (header, message) = separate L.null ls + ls = L.split nl b + + -- author and committer lines have the form: "name <email> date" + -- The email is always present, even if empty "<>" + parsemetadata l = CommitMetaData + { commitName = whenset $ L.init name_sp + , commitEmail = whenset email + , commitDate = whenset $ L.drop 2 gt_sp_date + } + where + (name_sp, rest) = L.break (== lt) l + (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest) + whenset v + | L.null v = Nothing + | otherwise = Just (L8.unpack v) + + nl = fromIntegral (ord '\n') + sp = fromIntegral (ord ' ') + lt = fromIntegral (ord '<') + gt = fromIntegral (ord '>') diff --git a/Git/Command.hs b/Git/Command.hs index 02e3e5a..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,15 +14,20 @@ 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 { } ) }) = - setdir : settree ++ gitGlobalOpts r ++ params + setdir ++ settree ++ gitGlobalOpts r ++ params where - setdir = Param $ "--git-dir=" ++ gitdir l + setdir + | gitEnvOverridesGitDir r = [] + | 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. -} @@ -45,14 +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 } - fileEncoding h - c <- hGetContents h + c <- L.hGetContents h return (c, checkSuccessProcess pid) where p = gitCreateProcess params repo @@ -61,11 +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 - fileEncoding h - output <- hGetContentsStrict h + output <- reader h hClose h return output where @@ -79,34 +86,40 @@ pipeWriteRead params writer repo = assertLocal repo $ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) writer (Just adjusthandle) where - adjusthandle h = do - fileEncoding h - hSetNewlineMode h noNewlineTranslation + adjusthandle h = hSetNewlineMode h noNewlineTranslation {- 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) $ split 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) $ split 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 3d62395..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,26 +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 - -- We use the FileSystemEncoding when reading from git-config, - -- because it can contain arbitrary filepaths (and other strings) - -- in any encoding. - fileEncoding h - 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. - @@ -108,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 @@ -122,53 +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' $ split "\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 - fileEncoding h - val <- hGetContentsStrict h + val <- S.hGetContents h r' <- store val r return (r', val) where @@ -176,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" @@ -186,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, @@ -201,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 03dd29f..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 #-} @@ -26,7 +26,7 @@ module Git.Construct ( #ifndef mingw32_HOST_OS import System.Posix.User #endif -import qualified Data.Map as M hiding (map, split) +import qualified Data.Map as M import Network.URI import Common @@ -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. -} @@ -94,7 +94,7 @@ fromUrl url fromUrlStrict :: String -> IO Repo fromUrlStrict url - | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u + | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u | otherwise = pure $ newFrom $ Url u where u = fromMaybe bad $ parseURI url @@ -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 = startswith "remote." k && endswith ".url" 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 $ split "." 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,9 +238,9 @@ newFrom l = Repo { location = l , config = M.empty , fullconfig = M.empty - , remotes = [] , remoteName = Nothing , gitEnv = Nothing + , gitEnvOverridesGitDir = False , gitGlobalOpts = [] } diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index dab4ad2..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 } - configure Nothing Nothing = error "Not in a git repository." + 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 edc3c0f..66a0159 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,17 +5,21 @@ - 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, - fromTopFilePath, + BranchFilePath(..), + descBranchFilePath, getTopFilePath, + fromTopFilePath, toTopFilePath, asTopFilePath, InternalGitPath, @@ -27,23 +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 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) -{- A FilePath, relative to the top of the git repository. -} -newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } - deriving (Show) +{- Git uses the branch:file form to refer to a BranchFilePath -} +descBranchFilePath :: BranchFilePath -> S.ByteString +descBranchFilePath (BranchFilePath b f) = + encodeBS' (fromRef b) <> ":" <> getTopFilePath f -{- Returns an absolute FilePath. -} -fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath -fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p) +{- Path to a TopFilePath, within the provided git repo. -} +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 @@ -53,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 ee84d48..010e5ba 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -3,26 +3,53 @@ - - 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 +import Common import Utility.Format (decode_c, encode_c) -import Common +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 -} -prop_isomorphic_deencode :: String -> Bool -prop_isomorphic_deencode s = s == decode (encode s) +prop_encode_decode_roundtrip :: FilePath -> Bool +prop_encode_decode_roundtrip s = s' == + fromRawFilePath (decode (encode (toRawFilePath s'))) + where + 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 f3e6db9..6f33e11 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -2,9 +2,11 @@ - - 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 #-} + module Git.Fsck ( FsckResults(..), MissingObjects, @@ -20,12 +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 - -type MissingObjects = S.Set Sha +import qualified Data.Semigroup as Sem +import Prelude data FsckResults = FsckFoundMissing @@ -35,6 +36,31 @@ data FsckResults | FsckFailed deriving (Show) +data FsckOutput + = FsckOutput MissingObjects Truncated + | NoFsckOutput + | AllDuplicateEntriesWarning + +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 + {- 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 - the broken objects it does find. @@ -46,9 +72,7 @@ data FsckResults -} 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) @@ -58,18 +82,24 @@ findBroken batchmode r = do { std_out = CreatePipe , std_err = CreatePipe } - (bad1, bad2) <- concurrently - (readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p)) - (readMissingObjs maxobjs r supportsNoDangling (stderrHandle p)) + (o1, o2) <- concurrently + (parseFsckOutput maxobjs r (stdoutHandle p)) + (parseFsckOutput maxobjs r (stderrHandle p)) fsckok <- checkSuccessProcess pid - let truncated = S.size bad1 == maxobjs || S.size bad1 == maxobjs - let badobjs = S.union bad1 bad2 - - if S.null badobjs && not fsckok - then return FsckFailed - else return $ FsckFoundMissing badobjs truncated + case mappend o1 o2 of + FsckOutput badobjs truncated + | S.null badobjs && not fsckok -> return FsckFailed + | otherwise -> return $ FsckFoundMissing badobjs truncated + NoFsckOutput + | not fsckok -> return FsckFailed + | otherwise -> return noproblem + -- If all fsck output was duplicateEntries warnings, + -- the repository is not broken, it just has some unusual + -- tree objects in it. So ignore nonzero exit status. + AllDuplicateEntriesWarning -> return noproblem where maxobjs = 10000 + noproblem = FsckFoundMissing S.empty False foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True @@ -87,10 +117,18 @@ knownMissing (FsckFoundMissing s _) = s findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects -readMissingObjs maxobjs r supportsNoDangling h = do - objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h - findMissing objs r +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 ls + let !truncated = length shas > maxobjs + missingobjs <- findMissing (take maxobjs shas) r + return $ FsckOutput missingobjs truncated isMissing :: Sha -> Repo -> IO Bool isMissing s r = either (const True) (const False) <$> tryIO dump @@ -100,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 . lines +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 551fd98..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,10 +10,25 @@ module Git.Index where import Common import Git import Utility.Env +import Utility.Env.Set indexEnv :: String indexEnv = "GIT_INDEX_FILE" +{- Gets value to set GIT_INDEX_FILE to. Input should be absolute path, + - or relative to the CWD. + - + - When relative, GIT_INDEX_FILE is interpreted by git as being + - relative to the top of the work tree of the git repository, + - not to the CWD. Worse, other environment variables (GIT_WORK_TREE) + - or git options (--work-tree) or configuration (core.worktree) + - can change what the relative path is interpreted relative to. + - + - So, an absolute path is the only safe option for this to return. + -} +indexEnvVal :: FilePath -> IO String +indexEnvVal = absPath + {- Forces git to use the specified index file. - - Returns an action that will reset back to the default @@ -21,35 +36,25 @@ indexEnv = "GIT_INDEX_FILE" - - Warning: Not thread safe. -} -override :: FilePath -> IO (IO ()) -override index = do +override :: FilePath -> Repo -> IO (IO ()) +override index _r = do res <- getEnv var - setEnv var index True + val <- indexEnvVal index + setEnv var val True return $ reset res where var = "GIT_INDEX_FILE" 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 1ed6247..a3d8383 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,16 +1,21 @@ {- git ls-tree interface - - - Copyright 2011 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 + parseLsTree, + formatLsTree, ) where import Common @@ -19,37 +24,52 @@ import Git.Command import Git.Sha import Git.FilePath import qualified Git.Filename +import Utility.Attoparsec import Numeric +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 - , sha :: 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] -lsTree t repo = map parseLsTree - <$> pipeNullSplitZombie (lsTreeParams t []) repo +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] -> 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" @@ -59,20 +79,34 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo , File $ fromRef t ] ++ map File fs -{- Parses a line of ls-tree output. +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 = fst $ Prelude.head $ readOct m - , typeobj = t - , sha = s - , file = asTopFilePath $ Git.Filename.decode f - } - where - -- l = <mode> SP <type> SP <sha> TAB <file> - -- All fields are fixed, so we can pull them out of - -- specific positions in the line. - (m, past_m) = splitAt 7 l - (t, past_t) = splitAt 4 past_m - (s, past_s) = splitAt shaSize $ Prelude.tail past_t - f = Prelude.tail past_s +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,29 +15,39 @@ 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 = fromRawFilePath (localGitDir r) </> "HEAD" + +setHeadRef :: Ref -> Repo -> IO () +setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) + {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String describe = fromRef . base -{- Often git refs are fully qualified (eg: refs/heads/master). - - Converts such a fully qualified ref into a base ref (eg: master). -} +{- Often git refs are fully qualified + - (eg refs/heads/master or refs/remotes/origin/master). + - 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 - -{- Given a directory and any ref, takes the basename of the ref and puts - - it under the directory. -} -under :: String -> Ref -> Ref -under dir r = Ref $ dir ++ "/" ++ - (reverse $ takeWhile (/= '/') $ reverse $ fromRef r) + 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, @@ -43,14 +55,18 @@ under dir r = Ref $ dir ++ "/" ++ underBase :: String -> Ref -> Ref underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r) +{- Convert a branch such as "master" into a fully qualified ref. -} +branchRef :: Branch -> Ref +branchRef = underBase "refs/heads" + {- A Ref that can be used to refer to a file in the repository, as staged - in the index. - - 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 @@ -58,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. -} @@ -69,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 @@ -99,25 +120,47 @@ matching refs repo = matching' (map fromRef refs) repo matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo -{- List of (shas, branches) matching a given ref or refs. -} +{- 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 in (Ref r, Ref b) -{- List of (shas, branches) matching a given ref spec. +{- List of (shas, branches) matching a given ref. - Duplicate shas are filtered out. -} matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingUniq refs repo = nubBy uniqref <$> matching refs repo where uniqref (a, _) (b, _) = a == b -{- Gets the sha of the tree a ref uses. -} +{- List of all refs. -} +list :: Repo -> IO [(Sha, Ref)] +list = matching' [] + +{- Deletes a ref. This can delete refs that are not branches, + - which git branch --delete refuses to delete. -} +delete :: Sha -> Ref -> Repo -> IO () +delete oldvalue ref = run + [ Param "update-ref" + , Param "-d" + , Param $ fromRef ref + , Param $ fromRef oldvalue + ] + +{- 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 = extractSha <$$> pipeReadStrict - [ Param "rev-parse", Param (fromRef ref ++ ":") ] +tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict + [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] + where + ref' = if ":" `isInfixOf` ref + then ref + -- de-reference commit objects to the tree + else ref ++ ":" {- Checks if a String is a legal git ref name. - @@ -142,6 +185,6 @@ legal allowonelevel s = all (== False) illegal ends v = v `isSuffixOf` s begins v = v `isPrefixOf` s - pathbits = split "/" s + pathbits = splitc '/' s illegalchars = " ~^:?*[\\" ++ controlchars controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)] 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 717b540..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) -> - startswith prefix k && - endswith suffix k && - startswith v 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 b441f13..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,13 +35,13 @@ 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 import qualified Data.Set as S import qualified Data.ByteString.Lazy as L -import Data.Tuple.Utils {- Given a set of bad objects found by git fsck, which may not - be complete, finds and removes all corrupt objects. -} @@ -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,9 +341,9 @@ 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 (extractSha . LsTree.sha . LsTree.parseLsTree) ls - if any isNothing objshas || any (`S.member` missing) (catMaybes objshas) + (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 return False @@ -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. -} @@ -614,4 +614,4 @@ successfulRepair = fst safeReadFile :: FilePath -> IO String safeReadFile f = do allowRead f - readFileStrictAnyEncoding f + readFileStrict f @@ -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 bb91a17..9c2754a 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,17 +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.URI () +import Utility.FileSystemEncoding {- Support repositories on local disk, and repositories accessed via an URL. - @@ -24,26 +30,54 @@ import Utility.URI () - 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)] + , gitEnvOverridesGitDir :: Bool -- global options to pass to git when running git commands , 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,37 +98,61 @@ 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 +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 + , commitParent :: [Sha] + , commitAuthorMetaData :: CommitMetaData + , commitCommitterMetaData :: CommitMetaData + , commitMessage :: String + } + deriving (Show) + +data CommitMetaData = CommitMetaData + { commitName :: Maybe String + , commitEmail :: Maybe String + , commitDate :: Maybe String -- In raw git form, "epoch -tzoffset" + } + deriving (Show) diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 55c5b3b..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,14 +51,13 @@ 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 (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) { std_in = CreatePipe } - fileEncoding h return $ UpdateIndexHandle p h where params = map Param ["update-index", "-z", "--index-info"] @@ -84,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 #-} @@ -1,14 +1,25 @@ +# set to "./Setup" if you lack a cabal program. Or can be set to "stack" +BUILDER?=cabal +GHC?=ghc + PREFIX=/usr -CABAL?=cabal # set to "./Setup" if you lack a cabal program build: Build/SysConfig.hs - $(CABAL) build - ln -sf dist/build/git-repair/git-repair git-repair + $(BUILDER) build $(BUILDEROPTIONS) + if [ "$(BUILDER)" = stack ]; then \ + ln -sf $$(stack path --dist-dir)/build/git-annex/git-repair git-repair; \ + else \ + ln -sf dist/build/git-repair/git-repair git-repair; \ + fi @$(MAKE) tags >/dev/null 2>&1 & -Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs - if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi - $(CABAL) configure --ghc-options="$(shell Build/collect-ghc-options.sh)" +Build/SysConfig.hs: Build/TestConfig.hs Build/Configure.hs + if [ "$(BUILDER)" = ./Setup ]; then ghc --make Setup; fi + if [ "$(BUILDER)" = stack ]; then \ + $(BUILDER) build $(BUILDEROPTIONS); \ + else \ + $(BUILDER) configure --ghc-options="$(shell Build/collect-ghc-options.sh)"; \ + fi install: build install -d $(DESTDIR)$(PREFIX)/bin @@ -22,11 +33,6 @@ clean: find . -name \*.o -exec rm {} \; find . -name \*.hi -exec rm {} \; -# Upload to hackage. -hackage: clean - ./Build/make-sdist.sh - @cabal upload dist/*.tar.gz - # hothasktags chokes on some template haskell etc, so ignore errors tags: (for f in $$(find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$'); do hothasktags -c --cpp -c -traditional -c --include=dist/build/autogen/cabal_macros.h $$f; done) 2>/dev/null | sort > tags @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} + {- cabal setup file -} import Distribution.Simple 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/CoProcess.hs b/Utility/CoProcess.hs index 9854b47..2bae40f 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -13,7 +13,6 @@ module Utility.CoProcess ( start, stop, query, - rawMode ) where import Common @@ -44,7 +43,15 @@ start numrestarts cmd params environ = do start' :: CoProcessSpec -> IO CoProcessState start' s = do (pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s) + rawMode from + rawMode to return $ CoProcessState pid to from s + where +#ifdef mingw32_HOST_OS + rawMode h = hSetNewlineMode h noNewlineTranslation +#else + rawMode _ = return () +#endif stop :: CoProcessHandle -> IO () stop ch = do @@ -79,16 +86,3 @@ query ch send receive = do { coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 } putMVar ch s' query ch send receive - -rawMode :: CoProcessHandle -> IO CoProcessHandle -rawMode ch = do - s <- readMVar ch - raw $ coProcessFrom s - raw $ coProcessTo s - return ch - where - raw h = do - fileEncoding h -#ifdef mingw32_HOST_OS - hSetNewlineMode h noNewlineTranslation -#endif 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/DataUnits.hs b/Utility/DataUnits.hs new file mode 100644 index 0000000..a6c9ffc --- /dev/null +++ b/Utility/DataUnits.hs @@ -0,0 +1,166 @@ +{- data size display and parsing + - + - Copyright 2011 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + - + - + - And now a rant: + - + - In the beginning, we had powers of two, and they were good. + - + - Disk drive manufacturers noticed that some powers of two were + - sorta close to some powers of ten, and that rounding down to the nearest + - power of ten allowed them to advertise their drives were bigger. This + - was sorta annoying. + - + - Then drives got big. Really, really big. This was good. + - + - Except that the small rounding error perpretrated by the drive + - manufacturers suffered the fate of a small error, and became a large + - error. This was bad. + - + - So, a committee was formed. And it arrived at a committee-like decision, + - which satisfied noone, confused everyone, and made the world an uglier + - place. As with all committees, this was meh. + - + - And the drive manufacturers happily continued selling drives that are + - increasingly smaller than you'd expect, if you don't count on your + - fingers. But that are increasingly too big for anyone to much notice. + - This caused me to need git-annex. + - + - Thus, I use units here that I loathe. Because if I didn't, people would + - be confused that their drives seem the wrong size, and other people would + - complain at me for not being standards compliant. And we call this + - progress? + -} + +module Utility.DataUnits ( + dataUnits, + storageUnits, + memoryUnits, + bandwidthUnits, + oldSchoolUnits, + Unit(..), + ByteSize, + + roughSize, + roughSize', + compareSizes, + readSize +) where + +import Data.List +import Data.Char + +import Utility.HumanNumber + +type ByteSize = Integer +type Name = String +type Abbrev = String +data Unit = Unit ByteSize Abbrev Name + deriving (Ord, Show, Eq) + +dataUnits :: [Unit] +dataUnits = storageUnits ++ memoryUnits + +{- Storage units are (stupidly) powers of ten. -} +storageUnits :: [Unit] +storageUnits = + [ Unit (p 8) "YB" "yottabyte" + , Unit (p 7) "ZB" "zettabyte" + , Unit (p 6) "EB" "exabyte" + , Unit (p 5) "PB" "petabyte" + , Unit (p 4) "TB" "terabyte" + , Unit (p 3) "GB" "gigabyte" + , Unit (p 2) "MB" "megabyte" + , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 1000^n + +{- Memory units are (stupidly named) powers of 2. -} +memoryUnits :: [Unit] +memoryUnits = + [ Unit (p 8) "YiB" "yobibyte" + , Unit (p 7) "ZiB" "zebibyte" + , Unit (p 6) "EiB" "exbibyte" + , Unit (p 5) "PiB" "pebibyte" + , Unit (p 4) "TiB" "tebibyte" + , Unit (p 3) "GiB" "gibibyte" + , Unit (p 2) "MiB" "mebibyte" + , Unit (p 1) "KiB" "kibibyte" + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 2^(n*10) + +{- Bandwidth units are only measured in bits if you're some crazy telco. -} +bandwidthUnits :: [Unit] +bandwidthUnits = error "stop trying to rip people off" + +{- Do you yearn for the days when men were men and megabytes were megabytes? -} +oldSchoolUnits :: [Unit] +oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits + where + mingle (Unit _ a n, Unit s' _ _) = Unit s' a n + +{- approximate display of a particular number of bytes -} +roughSize :: [Unit] -> Bool -> ByteSize -> String +roughSize units short i = roughSize' units short 2 i + +roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String +roughSize' units short precision i + | i < 0 = '-' : findUnit units' (negate i) + | otherwise = findUnit units' i + where + units' = sortBy (flip compare) units -- largest first + + findUnit (u@(Unit s _ _):us) i' + | i' >= s = showUnit i' u + | otherwise = findUnit us i' + findUnit [] i' = showUnit i' (last units') -- bytes + + showUnit x (Unit size abbrev name) = s ++ " " ++ unit + where + v = (fromInteger x :: Double) / fromInteger size + s = showImprecise precision v + unit + | short = abbrev + | s == "1" = name + | otherwise = name ++ "s" + +{- displays comparison of two sizes -} +compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String +compareSizes units abbrev old new + | old > new = roughSize units abbrev (old - new) ++ " smaller" + | old < new = roughSize units abbrev (new - old) ++ " larger" + | otherwise = "same" + +{- Parses strings like "10 kilobytes" or "0.5tb". -} +readSize :: [Unit] -> String -> Maybe ByteSize +readSize units input + | null parsednum || null parsedunit = Nothing + | otherwise = Just $ round $ number * fromIntegral multiplier + where + (number, rest) = head parsednum + multiplier = head parsedunit + unitname = takeWhile isAlpha $ dropWhile isSpace rest + + parsednum = reads input :: [(Double, String)] + parsedunit = lookupUnit units unitname + + lookupUnit _ [] = [1] -- no unit given, assume bytes + lookupUnit [] _ = [] + lookupUnit (Unit s a n:us) v + | a ~~ v || n ~~ v = [s] + | plural n ~~ v || a ~~ byteabbrev v = [s] + | otherwise = lookupUnit us v + + a ~~ b = map toLower a == map toLower b + + plural n = n ++ "s" + byteabbrev a = a ++ "b" diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 693e771..e2c6a94 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,22 +16,18 @@ module Utility.Directory ( import System.IO.Error 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 import Utility.SystemDirectory -import Utility.PosixFiles import Utility.Tmp import Utility.Exception import Utility.Monad @@ -96,10 +92,10 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] go c (dir:dirs) | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do - subdirs <- go c + subdirs <- go [] =<< filterM (isDirectory <$$> getSymbolicLinkStatus) =<< catchDefaultIO [] (dirContents dir) - go (subdirs++[dir]) dirs + go (subdirs++dir:c) dirs {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} @@ -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 ebf4c0b..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,14 +22,17 @@ 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. -} normalize :: String -> DottedVersion normalize v = DottedVersion v $ sum $ mult 1 $ reverse $ extend precision $ take precision $ - map readi $ split "." v + map readi $ splitc '.' v where extend n l = l ++ replicate (n - length l) 0 mult _ [] = [] 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 8b110ae..bcadb78 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2015 Joey Hess <id@joeyh.name> + - Copyright 2011-2016 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.Exception ( module X, + giveup, catchBoolIO, catchMaybeIO, catchDefaultIO, @@ -21,12 +22,14 @@ module Utility.Exception ( tryNonAsync, tryWhenExists, catchIOErrorType, - IOErrorType(..) + IOErrorType(..), + catchPermissionDenied, ) where import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException) +import Control.Exception (SomeAsyncException) import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType) @@ -34,6 +37,13 @@ import GHC.IO.Exception (IOErrorType(..)) import Utility.Data +{- Like error, this throws an exception. Unlike error, if this exception + - is not caught, it won't generate a backtrace. So use this for situations + - where there's a problem that the user is excpected to see in some + - circumstances. -} +giveup :: [Char] -> a +giveup = errorWithoutStackTrace + {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False @@ -73,6 +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) + , M.Handler (\ (e :: SomeAsyncException) -> throwM e) , M.Handler (\ (e :: SomeException) -> onerr e) ] @@ -97,3 +108,6 @@ catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching onlymatching e | ioeGetErrorType e == errtype = onmatchingerr e | otherwise = throwM e + +catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a +catchPermissionDenied = catchIOErrorType PermissionDenied diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index efef5fa..7d36c55 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,6 +1,6 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2017 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -15,12 +15,13 @@ module Utility.FileMode ( import System.IO import Control.Monad import System.PosixCompat.Types -import Utility.PosixFiles +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) import Foreign (complement) -import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Catch import Utility.Exception @@ -68,6 +69,7 @@ otherGroupModes :: [FileMode] otherGroupModes = [ groupReadMode, otherReadMode , groupWriteMode, otherWriteMode + , groupExecuteMode, otherExecuteMode ] {- Removes the write bits from a file. -} @@ -129,6 +131,21 @@ withUmask umask a = bracket setup cleanup go withUmask _ a = a #endif +getUmask :: IO FileMode +#ifndef mingw32_HOST_OS +getUmask = bracket setup cleanup return + where + setup = setFileCreationMask nullFileMode + cleanup = setFileCreationMask +#else +getUmask = return nullFileMode +#endif + +defaultFileMode :: IO FileMode +defaultFileMode = do + umask <- getUmask + return $ intersectFileModes (complement umask) stdFileMode + combineModes :: [FileMode] -> FileMode combineModes [] = 0 combineModes [m] = m @@ -161,7 +178,10 @@ writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () -writeFileProtected' file writer = withUmask 0o0077 $ +writeFileProtected' file writer = protectedOutput $ withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h + +protectedOutput :: IO a -> IO a +protectedOutput = withUmask 0o0077 diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index 1055754..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 @@ -13,21 +18,26 @@ import Control.Exception (bracket) import System.IO #endif +type FileSize = Integer + {- Gets the size of a file. - - This is better than using fileSize, because on Windows that returns a - FileOffset which maxes out at 2 gb. - See https://github.com/jystic/unix-compat/issues/16 -} -getFileSize :: FilePath -> IO Integer +getFileSize :: FilePath -> IO FileSize #ifndef mingw32_HOST_OS getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) #else getFileSize f = bracket (openFile f ReadMode) hClose hFileSize #endif -{- Gets the size of the file, when its FileStatus is already known. -} -getFileSize' :: FilePath -> FileStatus -> IO Integer +{- 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 #else diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 67341d3..f9e9814 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess <id@joeyh.name> + - Copyright 2012-2016 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -9,16 +9,25 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( + useFileSystemEncoding, fileEncoding, withFilePath, - md5FilePath, + RawFilePath, + fromRawFilePath, + toRawFilePath, + decodeBL, + encodeBL, decodeBS, encodeBS, - decodeW8, - encodeW8, - encodeW8NUL, - decodeW8NUL, + decodeBL', + encodeBL', + decodeBS', + encodeBS', truncateFilePath, + s2w8, + w82s, + c2w8, + w82c, ) where import qualified GHC.Foreign as GHC @@ -26,29 +35,47 @@ import qualified GHC.IO.Encoding as Encoding import Foreign.C import System.IO import System.IO.Unsafe -import qualified Data.Hash.MD5 as MD5 import Data.Word -import Data.Bits.Utils import Data.List -import Data.List.Utils +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 import Utility.Exception +import Utility.Split -{- Sets a Handle to use the filesystem encoding. This causes data - - written or read from it to be encoded/decoded the same - - as ghc 7.4 does to filenames etc. This special encoding - - allows "arbitrary undecodable bytes to be round-tripped through it". +{- Makes all subsequent Handles that are opened, as well as stdio Handles, + - use the filesystem encoding, instead of the encoding of the current + - locale. + - + - The filesystem encoding allows "arbitrary undecodable bytes to be + - round-tripped through it". This avoids encoded failures when data is not + - encoded matching the current locale. + - + - Note that code can still use hSetEncoding to change the encoding of a + - Handle. This only affects the default encoding. -} +useFileSystemEncoding :: IO () +useFileSystemEncoding = do +#ifndef mingw32_HOST_OS + e <- Encoding.getFileSystemEncoding +#else + {- The file system encoding does not work well on Windows, + - and Windows only has utf FilePaths anyway. -} + let e = Encoding.utf8 +#endif + hSetEncoding stdin e + hSetEncoding stdout e + hSetEncoding stderr e + Encoding.setLocaleEncoding e + fileEncoding :: Handle -> IO () #ifndef mingw32_HOST_OS fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding #else -{- The file system encoding does not work well on Windows, - - and Windows only has utf FilePaths anyway. -} fileEncoding h = hSetEncoding h Encoding.utf8 #endif @@ -82,36 +109,92 @@ _encodeFilePath fp = unsafePerformIO $ do GHC.withCString enc fp (GHC.peekCString Encoding.char8) `catchNonAsync` (\_ -> return fp) -{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} -md5FilePath :: FilePath -> MD5.Str -md5FilePath = MD5.Str . _encodeFilePath - {- 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 +encodeBL = L.pack . decodeW8NUL +#else +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 -encodeBS = L.pack . decodeW8NUL +decodeBS' = encodeW8 . S.unpack #else -encodeBS = L8.fromString +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 @@ -119,21 +202,31 @@ 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 {- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul) +encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul) where - nul = ['\NUL'] + nul = '\NUL' decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul +decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where - nul = ['\NUL'] + nul = '\NUL' + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral + +s2w8 :: String -> [Word8] +s2w8 = map c2w8 + +w82s :: [Word8] -> String +w82s = map w82c {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. diff --git a/Utility/Format.hs b/Utility/Format.hs index 7844963..a2470fa 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -11,11 +11,11 @@ module Utility.Format ( format, decode_c, encode_c, - prop_isomorphic_deencode + prop_encode_c_decode_c_roundtrip ) 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) @@ -100,10 +100,10 @@ empty :: Frag -> Bool empty (Const "") = True empty _ = False -{- Decodes a C-style encoding, where \n is a newline, \NNN is an octal - - encoded character, and \xNN is a hex encoded character. +{- Decodes a C-style encoding, where \n is a newline (etc), + - \NNN is an octal encoded character, and \xNN is a hex encoded character. -} -decode_c :: FormatString -> FormatString +decode_c :: FormatString -> String decode_c [] = [] decode_c s = unescape ("", s) where @@ -141,14 +141,14 @@ decode_c s = unescape ("", s) handle n = ("", n) {- Inverse of decode_c. -} -encode_c :: FormatString -> FormatString +encode_c :: String -> FormatString encode_c = encode_c' (const False) {- Encodes more strictly, including whitespace. -} -encode_c_strict :: FormatString -> FormatString +encode_c_strict :: String -> FormatString encode_c_strict = encode_c' isSpace -encode_c' :: (Char -> Bool) -> FormatString -> FormatString +encode_c' :: (Char -> Bool) -> String -> FormatString encode_c' p = concatMap echar where e c = '\\' : [c] @@ -173,6 +173,15 @@ encode_c' p = concatMap echar e_asc c = showoctal $ ord c showoctal i = '\\' : printf "%03o" i -{- for quickcheck -} -prop_isomorphic_deencode :: String -> Bool -prop_isomorphic_deencode s = s == decode_c (encode_c s) +{- For quickcheck. + - + - Encoding and then decoding roundtrips only when + - 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 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 isAscii s diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs new file mode 100644 index 0000000..6143cef --- /dev/null +++ b/Utility/HumanNumber.hs @@ -0,0 +1,21 @@ +{- numbers for humans + - + - Copyright 2012-2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.HumanNumber (showImprecise) where + +{- Displays a fractional value as a string with a limited number + - of decimal digits. -} +showImprecise :: RealFrac a => Int -> a -> String +showImprecise precision n + | precision == 0 || remainder == 0 = show (round n :: Integer) + | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder) + where + int :: Integer + (int, frac) = properFraction n + remainder = round (frac * 10 ^ precision) :: Integer + pad0s s = replicate (precision - length s) '0' ++ s + striptrailing0s = reverse . dropWhile (== '0') . reverse diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs new file mode 100644 index 0000000..01fbeac --- /dev/null +++ b/Utility/HumanTime.hs @@ -0,0 +1,104 @@ +{- Time for humans. + - + - Copyright 2012-2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.HumanTime ( + Duration(..), + durationSince, + durationToPOSIXTime, + durationToDays, + daysToDuration, + parseDuration, + fromDuration, + prop_duration_roundtrips +) where + +import Utility.PartialPrelude +import Utility.QuickCheck + +import qualified Data.Map as M +import Data.Time.Clock +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Char +import Control.Applicative +import Prelude + +newtype Duration = Duration { durationSeconds :: Integer } + deriving (Eq, Ord, Read, Show) + +durationSince :: UTCTime -> IO Duration +durationSince pasttime = do + now <- getCurrentTime + return $ Duration $ round $ diffUTCTime now pasttime + +durationToPOSIXTime :: Duration -> POSIXTime +durationToPOSIXTime = fromIntegral . durationSeconds + +durationToDays :: Duration -> Integer +durationToDays d = durationSeconds d `div` dsecs + +daysToDuration :: Integer -> Duration +daysToDuration i = Duration $ i * dsecs + +{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} +parseDuration :: Monad m => String -> m Duration +parseDuration = maybe parsefail (return . Duration) . go 0 + where + go n [] = return n + go n s = do + num <- readish s :: Maybe Integer + case dropWhile isDigit s of + (c:rest) -> do + u <- M.lookup c unitmap + go (n + num * u) rest + _ -> return $ n + num + parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\"" + +fromDuration :: Duration -> String +fromDuration Duration { durationSeconds = d } + | d == 0 = "0s" + | otherwise = concatMap showunit $ take 2 $ go [] units d + where + showunit (u, n) = show n ++ [u] + go c [] _ = reverse c + go c ((u, n):us) v = + let (q,r) = v `quotRem` n + 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 = + [ ('y', ysecs) + , ('d', dsecs) + , ('h', hsecs) + , ('m', msecs) + , ('s', 1) + ] + +unitmap :: M.Map Char Integer +unitmap = M.fromList units + +ysecs :: Integer +ysecs = dsecs * 365 + +dsecs :: Integer +dsecs = hsecs * 24 + +hsecs :: Integer +hsecs = msecs * 60 + +msecs :: Integer +msecs = 60 + +-- Durations cannot be negative. +instance Arbitrary Duration where + arbitrary = Duration <$> nonNegative arbitrary + +prop_duration_roundtrips :: Duration -> Bool +prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d diff --git a/Utility/Metered.hs b/Utility/Metered.hs index da83fd8..ec16e33 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,15 +1,51 @@ {- Metered IO and actions - - - Copyright 2012-2105 Joey Hess <id@joeyh.name> + - Copyright 2012-2018 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} -{-# LANGUAGE TypeSynonymInstances #-} - -module Utility.Metered where +{-# LANGUAGE TypeSynonymInstances, BangPatterns #-} + +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.Percentage +import Utility.DataUnits +import Utility.HumanTime import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -17,10 +53,11 @@ import System.IO.Unsafe import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types import Data.Int -import Data.Bits.Utils import Control.Concurrent import Control.Concurrent.Async import Control.Monad.IO.Class (MonadIO) +import Data.Time.Clock +import Data.Time.Clock.POSIX {- An action that can be run repeatedly, updating it on the bytes processed. - @@ -76,19 +113,17 @@ 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 = go zeroBytesProcessed . L.toChunks +meteredWrite meterupdate h = void . meteredWrite' meterupdate h + +meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed +meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks where - go _ [] = return () + go sofar [] = return sofar go sofar (c:cs) = do S.hPut h c - let sofar' = addBytesProcessed sofar $ S.length c + let !sofar' = addBytesProcessed sofar $ S.length c meterupdate sofar' go sofar' cs @@ -110,30 +145,30 @@ offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n) - meter updates, so use caution. -} hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString -hGetContentsMetered h = hGetUntilMetered h (const True) +hGetContentsMetered h = hGetMetered h Nothing -{- Reads from the Handle, updating the meter after each chunk. +{- Reads from the Handle, updating the meter after each chunk is read. + - + - Stops at EOF, or when the requested number of bytes have been read. + - Closes the Handle at EOF, but otherwise leaves it open. - - Note that the meter update is run in unsafeInterleaveIO, which means that - it can be run at any time. It's even possible for updates to run out - of order, as different parts of the ByteString are consumed. - - - - Stops at EOF, or when keepgoing evaluates to False. - - Closes the Handle at EOF, but otherwise leaves it open. -} -hGetUntilMetered :: Handle -> (Integer -> Bool) -> MeterUpdate -> IO L.ByteString -hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed +hGetMetered :: Handle -> Maybe Integer -> MeterUpdate -> IO L.ByteString +hGetMetered h wantsize meterupdate = lazyRead zeroBytesProcessed where lazyRead sofar = unsafeInterleaveIO $ loop sofar loop sofar = do - c <- S.hGet h defaultChunkSize + c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) if S.null c then do hClose h return $ L.empty else do - let sofar' = addBytesProcessed sofar (S.length c) + let !sofar' = addBytesProcessed sofar (S.length c) meterupdate sofar' if keepgoing (fromBytesProcessed sofar') then do @@ -143,6 +178,18 @@ hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed cs <- lazyRead sofar' return $ L.append (L.fromChunks [c]) cs else return $ L.fromChunks [c] + + keepgoing n = case wantsize of + Nothing -> True + Just sz -> n < sz + + nextchunksize n = case wantsize of + Nothing -> defaultChunkSize + Just sz -> + let togo = sz - n + in if togo < toInteger defaultChunkSize + then fromIntegral togo + else defaultChunkSize {- Same default chunk size Lazy ByteStrings use. -} defaultChunkSize :: Int @@ -151,22 +198,27 @@ defaultChunkSize = 32 * k - chunkOverhead k = 1024 chunkOverhead = 2 * sizeOf (1 :: Int) -- GHC specific -{- Runs an action, watching a file as it grows and updating the meter. -} +{- Runs an action, watching a file as it grows and updating the meter. + - + - The file may already exist, and the action could throw the original file + - away and start over. To avoid reporting the original file size followed + - by a smaller size in that case, wait until the file starts growing + - before updating the meter for the first time. + -} watchFileSize :: (MonadIO m, MonadMask m) => FilePath -> MeterUpdate -> m a -> m a watchFileSize f p a = bracket - (liftIO $ forkIO $ watcher zeroBytesProcessed) + (liftIO $ forkIO $ watcher =<< getsz) (liftIO . void . tryIO . killThread) (const a) where watcher oldsz = do - v <- catchMaybeIO $ toBytesProcessed <$> getFileSize f - newsz <- case v of - Just sz | sz /= oldsz -> do - p sz - return sz - _ -> return oldsz threadDelay 500000 -- 0.5 seconds - watcher newsz + sz <- getsz + when (sz > oldsz) $ + p sz + watcher sz + getsz = catchDefaultIO zeroBytesProcessed $ + toBytesProcessed <$> getFileSize f data OutputHandler = OutputHandler { quietMode :: Bool @@ -186,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 @@ -199,7 +258,7 @@ commandMeter progressparser oh meterupdate cmd params = unless (quietMode oh) $ do S.hPut stdout b hFlush stdout - let s = w82s (S.unpack b) + let s = decodeBS b let (mbytes, buf') = progressparser (buf++s) case mbytes of Nothing -> feedprogress prev buf' h @@ -221,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) $ @@ -246,16 +309,116 @@ 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 } + +-- | 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, 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) = readMVar totalsizev >>= \case + Just t | i >= t -> meterupdate n + _ -> do + now <- getPOSIXTime + prev <- takeMVar lastupdate + if now - prev >= delta + then do + putMVar lastupdate now + meterupdate n + else putMVar lastupdate prev + +data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter + +type MeterState = (BytesProcessed, POSIXTime) + +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 -> DisplayMeter -> IO Meter +mkMeter totalsize displaymeter = Meter + <$> newMVar totalsize + <*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime) + <*> newMVar "" + <*> pure displaymeter + +setMeterTotalSize :: Meter -> Integer -> IO () +setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just + +-- | Updates the meter, displaying it if necessary. +updateMeter :: Meter -> MeterUpdate +updateMeter (Meter totalsizev sv bv displaymeter) new = do + now <- getPOSIXTime + (old, before) <- swapMVar sv (new, now) + when (old /= new) $ do + totalsize <- readMVar totalsizev + displaymeter bv totalsize (old, before) (new, now) + +-- | Display meter to a Handle. +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 + let padding = replicate (length olds - length s) ' ' + hPutStr h ('\r':s ++ padding) + hFlush h + +-- | Clear meter displayed by displayMeterHandle. +clearMeterHandle :: Meter -> Handle -> IO () +clearMeterHandle (Meter _ _ v _) h = do + olds <- readMVar v + hPutStr h $ '\r' : replicate (length olds) ' ' ++ "\r" + hFlush h + +-- | Display meter in the form: +-- 10% 1.3MiB 300 KiB/s 16m40s +-- or when total size is not known: +-- 1.3 MiB 300 KiB/s +bandwidthMeter :: RenderMeter +bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) = + unwords $ catMaybes + [ 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 + 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 + | otherwise = floor $ fromIntegral transferred / duration + transferred = max 0 (new - old) + duration = max 0 (now - before) + estimatedcompletion = case mtotalsize of + Just totalsize + | bytespersecond > 0 -> + Just $ fromDuration $ Duration $ + (totalsize - new) `div` bytespersecond + _ -> Nothing diff --git a/Utility/Misc.hs b/Utility/Misc.hs index ebb4257..2f1766e 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -5,13 +5,22 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Misc where - -import Utility.FileSystemEncoding -import Utility.Monad +module Utility.Misc ( + hGetContentsStrict, + readFileStrict, + separate, + firstLine, + firstLine', + segment, + segmentDelim, + massReplace, + hGetSomeString, + exitBool, + + prop_segment_regressionTest, +) where import System.IO import Control.Monad @@ -19,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 @@ -35,20 +41,6 @@ hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s -{- Reads a file strictly, and using the FileSystemEncoding, so it will - - never crash on a badly encoded file. -} -readFileStrictAnyEncoding :: FilePath -> IO String -readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do - fileEncoding h - hClose h `after` hGetContentsStrict h - -{- Writes a file, using the FileSystemEncoding so it will never crash - - on a badly encoded content string. -} -writeFileAnyEncoding :: FilePath -> String -> IO () -writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do - fileEncoding h - hPutStr h content - {- Like break, but the item matching the condition is not included - in the second result list. - @@ -66,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. -} @@ -129,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 git processes. - - - - 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 5579556..90c67ff 100644 --- a/Utility/PartialPrelude.hs +++ b/Utility/PartialPrelude.hs @@ -2,12 +2,23 @@ - bugs. - - This exports functions that conflict with the prelude, which avoids - - them being accidentially used. + - them being accidentally used. -} {-# 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 f3290d8..ecc752c 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -5,30 +5,45 @@ - 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 Data.String.Utils import System.FilePath -import System.Directory import Data.List import Data.Maybe 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 qualified "MissingH" System.Path as MissingH 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. @@ -60,7 +75,7 @@ simplifyPath path = dropTrailingPathSeparator $ {- Makes a path absolute. - - The first parameter is a base directory (ie, the cwd) to use if the path - - is not already absolute. + - is not already absolute, and should itsef be absolute. - - Does not attempt to deal with edge cases or ensure security with - untrusted inputs. @@ -68,18 +83,6 @@ simplifyPath path = dropTrailingPathSeparator $ absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom dir path = simplifyPath (combine dir path) -{- On Windows, this converts the paths to unix-style, in order to run - - MissingH's absNormPath on them. -} -absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath -#ifndef mingw32_HOST_OS -absNormPathUnix dir path = MissingH.absNormPath dir path -#else -absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path) - where - fromdos = replace "\\" "/" - todos = replace "/" "\\" -#endif - {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath parentDir = takeDirectory . dropTrailingPathSeparator @@ -89,12 +92,13 @@ parentDir = takeDirectory . dropTrailingPathSeparator upFrom :: FilePath -> Maybe FilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive (intercalate s $ init dirs) + | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs where - -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" + -- on Unix, the drive will be "/" when the dir is absolute, + -- otherwise "" (drive, path) = splitDrive dir - dirs = filter (not . null) $ split s path s = [pathSeparator] + dirs = filter (not . null) $ split s path prop_upFrom_basics :: FilePath -> Bool prop_upFrom_basics dir @@ -109,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 @@ -148,17 +155,22 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to -} relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to - | takeDrive from /= takeDrive to = to - | otherwise = intercalate s $ dotdots ++ uncommon +#ifdef mingw32_HOST_OS + | normdrive from /= normdrive to = to +#endif + | otherwise = joinPath $ dotdots ++ uncommon where - s = [pathSeparator] - pfrom = split s from - pto = split s to + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath . dropDrive common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto dotdots = replicate (length pfrom - numcommon) ".." numcommon = length common +#ifdef mingw32_HOST_OS + normdrive = map toLower . takeWhile (/= ':') . takeDrive +#endif prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to @@ -192,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 ~/ -} @@ -227,6 +240,8 @@ inPath command = isJust <$> searchPath command - - The command may be fully qualified already, in which case it will - be returned if it exists. + - + - Note that this will find commands in PATH that are not executable. -} searchPath :: String -> IO (Maybe FilePath) searchPath command @@ -252,44 +267,6 @@ dotfile file where f = takeFileName file -{- Converts a DOS style path to a Cygwin style path. Only on Windows. - - Any trailing '\' is preserved as a trailing '/' -} -toCygPath :: FilePath -> FilePath -#ifndef mingw32_HOST_OS -toCygPath = id -#else -toCygPath p - | null drive = recombine parts - | otherwise = recombine $ "/cygdrive" : 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/Percentage.hs b/Utility/Percentage.hs new file mode 100644 index 0000000..a30c260 --- /dev/null +++ b/Utility/Percentage.hs @@ -0,0 +1,33 @@ +{- percentages + - + - Copyright 2012 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.Percentage ( + Percentage, + percentage, + showPercentage +) where + +import Data.Ratio + +import Utility.HumanNumber + +newtype Percentage = Percentage (Ratio Integer) + +instance Show Percentage where + show = showPercentage 0 + +{- Normally the big number comes first. But 110% is allowed if desired. :) -} +percentage :: Integer -> Integer -> Percentage +percentage 0 _ = Percentage 0 +percentage full have = Percentage $ have * 100 % full + +{- Pretty-print a Percentage, with a specified level of precision. -} +showPercentage :: Int -> Percentage -> String +showPercentage precision (Percentage p) = v ++ "%" + where + v = showImprecise precision n + n = fromRational p :: Double diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs deleted file mode 100644 index 4550beb..0000000 --- a/Utility/PosixFiles.hs +++ /dev/null @@ -1,34 +0,0 @@ -{- POSIX files (and compatablity wrappers). - - - - This is like System.PosixCompat.Files, except with a fixed rename. - - - - 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 -#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 diff --git a/Utility/Process.hs b/Utility/Process.hs index c669996..af3a5f4 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -18,16 +18,16 @@ module Utility.Process ( readProcessEnv, writeReadProcessEnv, forceSuccessProcess, + forceSuccessProcess', checkSuccessProcess, ignoreFailureProcess, createProcessSuccess, createProcessChecked, createBackgroundProcess, - processTranscript, - processTranscript', withHandle, withIOHandles, withOEHandles, + withNullHandle, withQuietOutput, feedWithQuietOutput, createProcess, @@ -53,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 @@ -129,11 +122,12 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do -- | Waits for a ProcessHandle, and throws an IOError if the process -- did not exit successfully. forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () -forceSuccessProcess p pid = do - code <- waitForProcess pid - case code of - ExitSuccess -> return () - ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n +forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p + +forceSuccessProcess' :: CreateProcess -> ExitCode -> IO () +forceSuccessProcess' _ ExitSuccess = return () +forceSuccessProcess' p (ExitFailure n) = fail $ + showCmd p ++ " exited " ++ show n -- | Waits for a ProcessHandle and returns True if it exited successfully. -- Note that using this with createProcessChecked will throw away @@ -168,70 +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 = processTranscript' id - -processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool) -processTranscript' modproc cmd opts 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 $ modproc $ - (proc cmd opts) - { 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 $ modproc $ - (proc cmd opts) - { 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 2009476..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,27 +15,24 @@ module Utility.QuickCheck import Test.QuickCheck as X import Data.Time.Clock.POSIX +import Data.Ratio import System.Posix.Types -import qualified Data.Map as M -import qualified Data.Set as S -import Control.Applicative +import Data.List.NonEmpty (NonEmpty(..)) import Prelude -#if ! MIN_VERSION_QuickCheck(2,8,2) -instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where - arbitrary = M.fromList <$> arbitrary - -instance (Arbitrary v, Eq 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 @@ -45,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 3aaf928..c6881b7 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -7,14 +7,28 @@ {-# 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 -import Data.Tuple.Utils {- Generates parameters to make rsync use a specified command as its remote - shell. -} @@ -24,7 +38,7 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman {- rsync requires some weird, non-shell like quoting in - here. A doubled single quote inside the single quoted - string is a single quote. -} - escape s = "'" ++ intercalate "''" (split "'" s) ++ "'" + escape s = "'" ++ intercalate "''" (splitc '\'' s) ++ "'" {- Runs rsync in server mode to send a file. -} rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool @@ -54,16 +68,16 @@ rsyncUseDestinationPermissions = Param "--chmod=ugo=rwX" rsync :: [CommandParam] -> IO Bool rsync = boolSystem "rsync" . rsyncParamsFixup -{- On Windows, rsync is from Cygwin, and expects to get Cygwin formatted +{- On Windows, rsync is from msys2, and expects to get msys2 formatted - paths to files. (It thinks that C:foo refers to a host named "C"). - Fix up the Params appropriately. -} rsyncParamsFixup :: [CommandParam] -> [CommandParam] #ifdef mingw32_HOST_OS rsyncParamsFixup = map fixup where - fixup (File f) = File (toCygPath f) + fixup (File f) = File (toMSYS2Path f) fixup (Param s) - | rsyncUrlIsPath s = Param (toCygPath s) + | rsyncUrlIsPath s = Param (toMSYS2Path s) fixup p = p #else rsyncParamsFixup = id @@ -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 @@ -123,7 +146,7 @@ parseRsyncProgress = go [] . reverse . progresschunks {- Find chunks that each start with delim. - The first chunk doesn't start with it - (it's empty when delim is at the start of the string). -} - progresschunks = drop 1 . split [delim] + progresschunks = drop 1 . splitc delim findbytesstart s = dropWhile isSpace s parsebytes :: String -> Maybe Integer @@ -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 5ce17a8..19d5f20 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -7,11 +7,27 @@ {-# 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 -import Data.String.Utils +import Utility.Split import System.FilePath import Data.Char import Data.List @@ -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. -- @@ -86,7 +104,7 @@ shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' - escaped = intercalate "'\"'\"'" $ split "'" f + escaped = intercalate "'\"'\"'" $ splitc '\'' f -- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] diff --git a/Utility/Split.hs b/Utility/Split.hs new file mode 100644 index 0000000..028218e --- /dev/null +++ b/Utility/Split.hs @@ -0,0 +1,39 @@ +{- split utility functions + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Split ( + split, + splitc, + replace, + dropFromEnd, +) where + +import Data.List (intercalate) +import Data.List.Split (splitOn) + +-- | same as Data.List.Utils.split +-- +-- intercalate x . splitOn x === id +split :: Eq a => [a] -> [a] -> [[a]] +split = splitOn + +-- | Split on a single character. This is over twice as fast as using +-- split on a list of length 1, while producing identical results. -} +splitc :: Eq c => c -> [c] -> [[c]] +splitc c s = case break (== c) s of + (i, _c:rest) -> i : splitc c rest + (i, []) -> i : [] + +-- | 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/SystemDirectory.hs b/Utility/SystemDirectory.hs index 3dd44d1..b9040fe 100644 --- a/Utility/SystemDirectory.hs +++ b/Utility/SystemDirectory.hs @@ -13,4 +13,4 @@ module Utility.SystemDirectory ( module System.Directory ) where -import System.Directory hiding (isSymbolicLink) +import System.Directory hiding (isSymbolicLink, getFileSize) 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 7610f6c..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,31 +8,33 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Tmp where +module Utility.Tmp ( + Template, + viaTmp, + withTmpFile, + withTmpFileIn, + relatedTemplate, +) where import System.IO -import System.Directory -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 System.PosixCompat.Files import Utility.Exception import Utility.FileSystemEncoding -import Utility.PosixFiles type Template = String {- Runs an action like writeFile, writing to a temp file first and - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. -} -viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m () +viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () 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 new file mode 100644 index 0000000..9638bcc --- /dev/null +++ b/Utility/Tuple.hs @@ -0,0 +1,21 @@ +{- tuple utility functions + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.Tuple ( + fst3, + snd3, + thd3, +) where + +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c diff --git a/Utility/URI.hs b/Utility/URI.hs deleted file mode 100644 index e68fda5..0000000 --- a/Utility/URI.hs +++ /dev/null @@ -1,18 +0,0 @@ -{- Network.URI - - - - Copyright 2014 Joey Hess <id@joeyh.name> - - - - License: BSD-2-clause - -} - -{-# LANGUAGE CPP #-} - -module Utility.URI where - --- Old versions of network lacked an Ord for URI -#if ! MIN_VERSION_network(2,4,0) -import Network.URI - -instance Ord URI where - a `compare` b = show a `compare` show b -#endif diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index 7e94caf..17ce8db 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -14,19 +14,21 @@ module Utility.UserInfo ( myUserGecos, ) where -import Utility.Env - -import System.PosixCompat +import Utility.Env.Basic +import Utility.Exception #ifndef mingw32_HOST_OS +import Utility.Data import Control.Applicative #endif + +import System.PosixCompat import Prelude {- Current user's home directory. - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath -myHomeDir = myVal env homeDirectory +myHomeDir = either giveup return =<< myVal env homeDirectory where #ifndef mingw32_HOST_OS env = ["HOME"] @@ -35,7 +37,7 @@ myHomeDir = myVal env homeDirectory #endif {- Current user's user name. -} -myUserName :: IO String +myUserName :: IO (Either String String) myUserName = myVal env userName where #ifndef mingw32_HOST_OS @@ -45,19 +47,23 @@ 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 = Just <$> myVal [] userGecos +myUserGecos = eitherToMaybe <$> myVal [] userGecos #endif -myVal :: [String] -> (UserEntry -> String) -> IO String +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 [] = 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 [] = error $ "environment not set: " ++ show envvars + get = return envnotset #endif - go (v:vs) = maybe (go vs) return =<< getEnv v + envnotset = Left ("environment not set: " ++ show envvars) diff --git a/configure.hs b/configure.hs deleted file mode 100644 index 15833e6..0000000 --- a/configure.hs +++ /dev/null @@ -1,6 +0,0 @@ -{- configure program -} - -import Build.Configure - -main :: IO () -main = run tests diff --git a/debian/rules b/debian/rules index 4d8fa21..9198916 100755 --- a/debian/rules +++ b/debian/rules @@ -1,7 +1,7 @@ #!/usr/bin/make -f # Avoid using cabal, as it writes to $HOME -export CABAL=./Setup +export BUILDER=./Setup # Do use the changelog's version number, rather than making one up. export RELEASE_BUILD=1 diff --git a/doc/index/discussion.mdwn b/doc/index/discussion.mdwn new file mode 100644 index 0000000..dea2ec7 --- /dev/null +++ b/doc/index/discussion.mdwn @@ -0,0 +1,12 @@ +My experience with git repair: + +git repair +Running git fsck ... +Stack space overflow: current size 8388608 bytes. +Use `+RTS -Ksize -RTS' to increase it. + +git repair +RTS -K32M -RTS +git-repair: Most RTS options are disabled. Link with -rtsopts to enable them. + +Whats up guys? Are we playing catch 22 here? + diff --git a/doc/news/version_1.20151215.mdwn b/doc/news/version_1.20151215.mdwn new file mode 100644 index 0000000..79b16f1 --- /dev/null +++ b/doc/news/version_1.20151215.mdwn @@ -0,0 +1,5 @@ +git-repair 1.20151215 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Fix insecure temporary permissions and potential denial of + service attack when creating temp dirs. Closes: #[807341](http://bugs.debian.org/807341) + * Merge from git-annex."""]]
\ No newline at end of file diff --git a/doc/news/version_1.20161111.mdwn b/doc/news/version_1.20161111.mdwn new file mode 100644 index 0000000..baba58b --- /dev/null +++ b/doc/news/version_1.20161111.mdwn @@ -0,0 +1,10 @@ +git-repair 1.20161111 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * git-repair.cabal: Add Setup-Depends. + * Updated cabal file explictly lists source files. The tarball + on hackage will include only the files needed for cabal install; + it is NOT the full git-repair source tree. + * debian/changelog: Converted to symlinks to CHANGELOG. + * Merge from git-annex. + * Makefile: Support building with stack as well as cabal. + * Makefile: The CABAL variable has been renamed to BUILDER."""]]
\ No newline at end of file diff --git a/doc/news/version_1.20161118.mdwn b/doc/news/version_1.20161118.mdwn new file mode 100644 index 0000000..c687f46 --- /dev/null +++ b/doc/news/version_1.20161118.mdwn @@ -0,0 +1,3 @@ +git-repair 1.20161118 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Fix build with recent versions of cabal and ghc."""]]
\ No newline at end of file diff --git a/doc/news/version_1.20170626.mdwn b/doc/news/version_1.20170626.mdwn new file mode 100644 index 0000000..9e9830a --- /dev/null +++ b/doc/news/version_1.20170626.mdwn @@ -0,0 +1,5 @@ +git-repair 1.20170626 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Merge from git-annex. + * Removes dependency on MissingH, adding a dependency on split instead. + * Fixes build with directory-1.3."""]]
\ No newline at end of file diff --git a/git-repair.cabal b/git-repair.cabal index d4583ea..f273cb3 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,13 +1,12 @@ Name: git-repair -Version: 1.20151215 +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 -Extra-Source-Files: CHANGELOG +License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/ Category: Utility @@ -21,29 +20,104 @@ Description: As well as avoiding the need to rm -rf a damaged repository and re-clone, using git-repair can help rescue commits you've made to the damaged repository and not yet pushed out. +Extra-Source-Files: + CHANGELOG + TODO + git-repair.1 -Flag network-uri - Description: Get Network.URI from the network-uri package - Default: True +custom-setup + 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 + type: git + location: git://git-repair.branchable.com/ Executable git-repair Main-Is: git-repair.hs GHC-Options: -threaded -Wall -fno-warn-tabs - Build-Depends: MissingH, 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) - - if flag(network-uri) - Build-Depends: network-uri (>= 2.6), network (>= 2.6) - else - Build-Depends: network (< 2.6), network (>= 2.0) + Extensions: LambdaCase + Build-Depends: split, hslogger, directory, filepath, containers, mtl, + 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) -source-repository head - type: git - location: git://git-repair.branchable.com/ + Other-Modules: + BuildInfo + Build.Configure + Build.TestConfig + Build.Version + Common + Git + Git.Branch + Git.BuildVersion + Git.CatFile + Git.Command + Git.Config + Git.Construct + Git.CurrentRepo + Git.Destroyer + Git.DiffTreeItem + Git.FilePath + Git.Filename + Git.Fsck + Git.HashObject + Git.Index + Git.LsFiles + Git.LsTree + Git.Objects + Git.Ref + Git.RefLog + Git.Remote + Git.Repair + Git.Sha + Git.Types + Git.UpdateIndex + Git.Url + Git.Version + Utility.Attoparsec + Utility.Applicative + Utility.Batch + Utility.CoProcess + Utility.Data + Utility.DataUnits + Utility.Directory + Utility.DottedVersion + Utility.Env + Utility.Env.Basic + Utility.Env.Set + Utility.Exception + Utility.FileMode + Utility.FileSize + Utility.FileSystemEncoding + Utility.Format + Utility.HumanNumber + Utility.HumanTime + Utility.Metered + Utility.Misc + Utility.Monad + Utility.PartialPrelude + Utility.Path + Utility.Percentage + Utility.Process + Utility.Process.Shim + Utility.QuickCheck + Utility.Rsync + Utility.SafeCommand + Utility.Split + Utility.SystemDirectory + Utility.ThreadScheduler + Utility.Tmp + Utility.Tmp.Dir + Utility.Tuple + Utility.UserInfo diff --git a/git-repair.hs b/git-repair.hs index a82d5d6..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,7 +14,7 @@ import qualified Git.Config import qualified Git.Construct import qualified Git.Destroyer import qualified Git.Fsck -import Utility.Tmp +import Utility.Tmp.Dir data Settings = Settings { forced :: Bool @@ -46,7 +46,9 @@ parseSettings = Settings ) main :: IO () -main = execParser opts >>= go +main = do + useFileSystemEncoding + execParser opts >>= go where opts = info (helper <*> parseSettings) desc desc = fullDesc |