git-repair (empty) → 1.20131118

raw patch · 56 files changed

+6034/−0 lines, 56 filesdep +IfElsedep +MissingHdep +asyncbuild-type:Customsetup-changed

Dependencies added: IfElse, MissingH, async, base, bytestring, containers, directory, extensible-exceptions, filepath, hslogger, mtl, network, pretty-show, process, text, unix, unix-compat, utf8-string

Files

• .gitignore +3/−0
• Build/Configure.hs +27/−0
• Build/TestConfig.hs +143/−0
• Build/make-sdist.sh +21/−0
• Common.hs +35/−0
• GPL +674/−0
• Git.hs +140/−0
• Git/Branch.hs +133/−0
• Git/BuildVersion.hs +21/−0
• Git/CatFile.hs +108/−0
• Git/Command.hs +138/−0
• Git/Config.hs +193/−0
• Git/Construct.hs +236/−0
• Git/CurrentRepo.hs +67/−0
• Git/FilePath.hs +64/−0
• Git/Filename.hs +28/−0
• Git/Fsck.hs +87/−0
• Git/LsFiles.hs +214/−0
• Git/LsTree.hs +65/−0
• Git/Objects.hs +29/−0
• Git/Ref.hs +133/−0
• Git/RefLog.hs +22/−0
• Git/Remote.hs +115/−0
• Git/Repair.hs +534/−0
• Git/Sha.hs +39/−0
• Git/Types.hs +95/−0
• Git/UpdateIndex.hs +86/−0
• Git/Url.hs +71/−0
• Git/Version.hs +43/−0
• Makefile +31/−0
• Setup.hs +14/−0
• Utility/Applicative.hs +16/−0
• Utility/Batch.hs +91/−0
• Utility/CoProcess.hs +93/−0
• Utility/Data.hs +17/−0
• Utility/Directory.hs +107/−0
• Utility/Env.hs +63/−0
• Utility/Exception.hs +59/−0
• Utility/FileMode.hs +135/−0
• Utility/FileSystemEncoding.hs +93/−0
• Utility/Format.hs +178/−0
• Utility/Metered.hs +116/−0
• Utility/Misc.hs +138/−0
• Utility/Monad.hs +69/−0
• Utility/PartialPrelude.hs +68/−0
• Utility/Path.hs +254/−0
• Utility/Process.hs +356/−0
• Utility/Rsync.hs +152/−0
• Utility/SafeCommand.hs +120/−0
• Utility/Tmp.hs +88/−0
• Utility/UserInfo.hs +55/−0
• configure.hs +6/−0
• doc/index.mdwn +46/−0
• git-repair.1 +37/−0
• git-repair.cabal +30/−0
• git-repair.hs +38/−0

@@ -0,0 +1,3 @@+Build/SysConfig.hs+tags+git-repair

@@ -0,0 +1,27 @@+{- Checks system configuration and generates SysConfig.hs. -}++module Build.Configure where++import System.Environment+import Control.Applicative+import Control.Monad.IfElse++import Build.TestConfig+import Git.Version++tests :: [TestCase]+tests =+	[ TestCase "git" $ requireCmd "git" "git --version >/dev/null"+	, TestCase "git version" getGitVersion+	, TestCase "nice" $ testCmd "nice" "nice true >/dev/null"+	]++getGitVersion :: Test+getGitVersion = Config "gitversion" . StringConfig . show+	<$> Git.Version.installed++run :: [TestCase] -> IO ()+run ts = do+	args <- getArgs+	config <- runTests ts+	writeSysConfig config

@@ -0,0 +1,143 @@+{- Tests the system and generates Build.SysConfig.hs. -}++module Build.TestConfig where++import Utility.Path+import Utility.Monad+import Utility.SafeCommand++import System.IO+import System.Cmd+import System.Exit+import System.FilePath+import System.Directory++type ConfigKey = String+data ConfigValue =+	BoolConfig Bool |+	StringConfig String |+	MaybeStringConfig (Maybe String) |+	MaybeBoolConfig (Maybe Bool)+data Config = Config ConfigKey ConfigValue++type Test = IO Config+type TestName = String+data TestCase = TestCase TestName Test++instance Show ConfigValue where+	show (BoolConfig b) = show b+	show (StringConfig s) = show s+	show (MaybeStringConfig s) = show s+	show (MaybeBoolConfig s) = show s++instance Show Config where+	show (Config key value) = unlines+		[ key ++ " :: " ++ valuetype value+		, key ++ " = " ++ show value+		]+	  where+		valuetype (BoolConfig _) = "Bool"+		valuetype (StringConfig _) = "String"+		valuetype (MaybeStringConfig _) = "Maybe String"+		valuetype (MaybeBoolConfig _) = "Maybe Bool"++writeSysConfig :: [Config] -> IO ()+writeSysConfig config = writeFile "Build/SysConfig.hs" body+  where+	body = unlines $ header ++ map show config ++ footer+	header = [+		  "{- Automatically generated. -}"+		, "module Build.SysConfig where"+		, ""+		]+	footer = []++runTests :: [TestCase] -> IO [Config]+runTests [] = return []+runTests (TestCase tname t : ts) = do+	testStart tname+	c <- t+	testEnd c+	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+	ok <- boolSystem "sh" [ Param "-c", Param $ quiet cmdline ]+	return $ Config k (BoolConfig ok)++{- Ensures that one of a set of commands is available by running each in+ - turn. The Config is set to the first one found. -}+selectCmd :: ConfigKey -> [(String, String)] -> Test+selectCmd k = searchCmd+		(return . Config k . StringConfig)+		(\cmds -> do+			testEnd $ Config k $ BoolConfig False+			error $ "* need one of these commands, but none are available: " ++ show cmds+		)++maybeSelectCmd :: ConfigKey -> [(String, String)] -> Test+maybeSelectCmd k = searchCmd+		(return . Config k . MaybeStringConfig . Just)+		(\_ -> return $ Config k $ MaybeStringConfig Nothing)++searchCmd :: (String -> Test) -> ([String] -> Test) -> [(String, String)] -> Test+searchCmd success failure cmdsparams = search cmdsparams+  where+	search [] = failure $ fst $ unzip cmdsparams+	search ((c, params):cs) = do+		ok <- boolSystem "sh" [ Param "-c", Param $ quiet $ c ++ " " ++ params ]+		if ok+			then success c+			else search cs++{- Finds a command, either in PATH or perhaps in a sbin directory not in+ - PATH. If it's in PATH the config is set to just the command name,+ - but if it's found outside PATH, the config is set to the full path to+ - the command. -}+findCmdPath :: ConfigKey -> String -> Test+findCmdPath k command = do+	ifM (inPath command)+		( return $ Config k $ MaybeStringConfig $ Just command+		, do+			r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"]+			return $ Config k $ MaybeStringConfig r+		)+  where+	find d =+		let f = d </> command+		in ifM (doesFileExist f) ( return (Just f), return Nothing )++quiet :: String -> String+quiet s = s ++ " >/dev/null 2>&1"++testStart :: TestName -> IO ()+testStart s = do+	putStr $ "  checking " ++ s ++ "..."+	hFlush stdout++testEnd :: Config -> IO ()+testEnd (Config _ (BoolConfig True)) = status "yes"+testEnd (Config _ (BoolConfig False)) = status "no"+testEnd (Config _ (StringConfig s)) = status s+testEnd (Config _ (MaybeStringConfig (Just s))) = status s+testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available"+testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes"+testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no"+testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown"++status :: String -> IO ()+status s = putStrLn $ ' ':s

@@ -0,0 +1,21 @@+#!/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 -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

@@ -0,0 +1,35 @@+{-# LANGUAGE PackageImports, CPP #-}++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.Exception.Extensible as X (IOException)++import Data.Maybe as X+import Data.List as X hiding (head, tail, init, last)+import Data.String.Utils as X hiding (join)++import System.FilePath as X+import System.Directory as X+import System.IO as X hiding (FilePath)+import System.PosixCompat.Files as X+#ifndef mingw32_HOST_OS+import System.Posix.IO as X+#endif+import System.Exit as X++import Utility.Misc as X+import Utility.Exception as X+import Utility.SafeCommand as X+import Utility.Process as X+import Utility.Path as X+import Utility.Directory as X+import Utility.Monad as X+import Utility.Data as X+import Utility.Applicative as X+import Utility.FileSystemEncoding as X++import Utility.PartialPrelude as X

@@ -0,0 +1,674 @@+                    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>.

@@ -0,0 +1,140 @@+{- git repository handling + -+ - This is written to be completely independant of git-annex and should be+ - suitable for other uses.+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Git (+	Repo(..),+	Ref(..),+	Branch,+	Sha,+	Tag,+	repoIsUrl,+	repoIsSsh,+	repoIsHttp,+	repoIsLocal,+	repoIsLocalBare,+	repoIsLocalUnknown,+	repoDescribe,+	repoLocation,+	repoPath,+	localGitDir,+	attributes,+	hookPath,+	assertLocal,+) where++import Network.URI (uriPath, uriScheme, unEscapeString)+#ifndef mingw32_HOST_OS+import System.Posix.Files+#endif++import Common+import Git.Types+#ifndef mingw32_HOST_OS+import Utility.FileMode+#endif++{- User-visible description of a git repo. -}+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 = 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 = Unknown } = undefined++{- 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 { location = Local { worktree = Just d } } = d+repoPath Repo { location = Local { gitdir = d } } = d+repoPath Repo { location = LocalUnknown dir } = dir+repoPath Repo { location = Unknown } = undefined++{- Path to a local repository's .git directory. -}+localGitDir :: Repo -> FilePath+localGitDir Repo { location = Local { gitdir = d } } = d+localGitDir _ = undefined++{- Some code needs to vary between URL and normal repos,+ - or bare and non-bare, these functions help with that. -}+repoIsUrl :: Repo -> Bool+repoIsUrl Repo { location = Url _ } = True+repoIsUrl _ = False++repoIsSsh :: Repo -> Bool+repoIsSsh Repo { location = Url url } +	| scheme == "ssh:" = True+	-- git treats these the same as ssh+	| scheme == "git+ssh:" = True+	| scheme == "ssh+git:" = True+	| otherwise = False+  where+	scheme = uriScheme url+repoIsSsh _ = False++repoIsHttp :: Repo -> Bool+repoIsHttp Repo { location = Url url } +	| uriScheme url == "http:" = True+	| uriScheme url == "https:" = True+	| otherwise = False+repoIsHttp _ = False++repoIsLocal :: Repo -> Bool+repoIsLocal Repo { location = Local { } } = True+repoIsLocal _ = False++repoIsLocalBare :: Repo -> Bool+repoIsLocalBare Repo { location = Local { worktree = Nothing } } = True+repoIsLocalBare _ = False++repoIsLocalUnknown :: Repo -> Bool+repoIsLocalUnknown Repo { location = LocalUnknown { } } = True+repoIsLocalUnknown _ = False++assertLocal :: Repo -> a -> a+assertLocal repo action+	| repoIsUrl repo = error $ unwords+		[ "acting on non-local git repo"+		, repoDescribe repo+		, "not supported"+		]+	| otherwise = action++{- Path to a repository's gitattributes file. -}+attributes :: Repo -> FilePath+attributes repo+	| repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes"+	| otherwise = repoPath repo ++ "/.gitattributes"++{- 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+	ifM (catchBoolIO $ isexecutable hook)+		( return $ Just hook , return Nothing )+  where+#if mingw32_HOST_OS+	isexecutable f = doesFileExist f+#else+	isexecutable f = isExecutable . fileMode <$> getFileStatus f+#endif

@@ -0,0 +1,133 @@+{- git branch stuff+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE BangPatterns #-}++module Git.Branch where++import Common+import Git+import Git.Sha+import Git.Command+import qualified Git.Ref++{- 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+ - to double-check.+ -}+current :: Repo -> IO (Maybe Git.Ref)+current r = do+	v <- currentUnsafe r+	case v of+		Nothing -> return Nothing+		Just branch -> +			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show 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+	<$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r+  where+	parse l+		| null l = Nothing+		| otherwise = Just $ Git.Ref l++{- 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+  where+	diffs = pipeReadStrict+		[ Param "log"+		, Param (show origbranch ++ ".." ++ show newbranch)+		, Params "--oneline -n1"+		] repo++{- Given a set of refs that are all known to have commits not+ - on the branch, tries to update the branch by a fast-forward.+ -+ - In order for that to be possible, one of the refs must contain+ - every commit present in all the other refs.+ -}+fastForward :: Branch -> [Ref] -> Repo -> IO Bool+fastForward _ [] _ = return True+fastForward branch (first:rest) repo =+	-- First, check that the branch does not contain any+	-- new commits that are not in the first ref. If it does,+	-- cannot fast-forward.+	ifM (changed first branch repo)+		( no_ff+		, maybe no_ff do_ff =<< findbest first rest+		)+  where+	no_ff = return False+	do_ff to = do+		run [Param "update-ref", Param $ show branch, Param $ show to] repo+		return True+	findbest c [] = return $ Just c+	findbest c (r:rs)+		| c == r = findbest c rs+		| otherwise = do+		better <- changed c r repo+		worse <- changed r c repo+		case (better, worse) of+			(True, True) -> return Nothing -- divergent fail+			(True, False) -> findbest r rs -- better+			(False, True) -> findbest c rs -- worse+			(False, False) -> findbest c rs -- same++{- Commits the index into the specified branch (or other ref), + - with the specified parent refs, and returns the committed sha -}+commit :: String -> Branch -> [Ref] -> Repo -> IO Sha+commit message branch parentrefs repo = do+	tree <- getSha "write-tree" $+		pipeReadStrict [Param "write-tree"] repo+	sha <- getSha "commit-tree" $ pipeWriteRead+		(map Param $ ["commit-tree", show tree] ++ ps)+		(Just $ flip hPutStr message) repo+	update branch sha repo+	return sha+  where+	ps = concatMap (\r -> ["-p", show 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 +	[ Param "update-ref"+	, Param $ show branch+	, Param $ show sha+	]++{- Checks out a branch, creating it if necessary. -}+checkout :: Branch -> Repo -> IO ()+checkout branch = run+	[ Param "checkout"+	, Param "-q"+	, Param "-B"+	, Param $ show $ Git.Ref.base branch+	]++{- Removes a branch. -}+delete :: Branch -> Repo -> IO ()+delete branch = run+	[ Param "branch"+	, Param "-q"+	, Param "-D"+	, Param $ show $ Git.Ref.base branch+	]

@@ -0,0 +1,21 @@+{- git build version+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.BuildVersion where++import Git.Version+import qualified Build.SysConfig++{- 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++older :: String -> Bool+older n = buildVersion < normalize n 

@@ -0,0 +1,108 @@+{- git cat-file interface+ -+ - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.CatFile (+	CatFileHandle,+	catFileStart,+	catFileStart',+	catFileStop,+	catFile,+	catTree,+	catObject,+	catObjectDetails,+) where++import System.IO+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Tuple.Utils+import Numeric+import System.Posix.Types++import Common+import Git+import Git.Sha+import Git.Command+import Git.Types+import Git.FilePath+import qualified Utility.CoProcess as CoProcess++data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo++catFileStart :: Repo -> IO CatFileHandle+catFileStart = catFileStart' True++catFileStart' :: Bool -> Repo -> IO CatFileHandle+catFileStart' restartable repo = do+	coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable+		[ Param "cat-file"+		, Param "--batch"+		] repo+	return $ CatFileHandle coprocess repo++catFileStop :: CatFileHandle -> IO ()+catFileStop (CatFileHandle p _) = CoProcess.stop p++{- Reads a file from a specified branch. -}+catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString+catFile h branch file = catObject h $ Ref $+	show branch ++ ":" ++ toInternalGitPath file++{- Uses a running git cat-file read the content of an object.+ - Objects that do not exist will have "" returned. -}+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+  where+	query = show 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 == show object ++ " missing" -> dne+				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)+	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"++{- Gets a list of files and directories in a tree. (Not recursive.) -}+catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)]+catTree h treeref = go <$> catObjectDetails h treeref+  where+	go (Just (b, _, TreeObject)) = parsetree [] b+  	go _ = []++	parsetree c b = case L.break (== 0) b of+		(modefile, rest)+			| L.null modefile -> c+			| otherwise -> parsetree+				(parsemodefile modefile:c)+				(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 (== ' ') (encodeW8 $ L.unpack b)+		in (file, readmode modestr)+	readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct

@@ -0,0 +1,138 @@+{- running git commands+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Git.Command where++import System.Process (std_out, env)++import Common+import Git+import Git.Types+import qualified Utility.CoProcess as CoProcess+#ifdef mingw32_HOST_OS+import Git.FilePath+#endif++{- 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+  where+	setdir = Param $ "--git-dir=" ++ gitpath (gitdir l)+	settree = case worktree l of+		Nothing -> []+		Just t -> [Param $ "--work-tree=" ++ gitpath t]+#ifdef mingw32_HOST_OS+	-- despite running on windows, msysgit wants a unix-formatted path+	gitpath s+		| isAbsolute s = "/" ++ dropDrive (toInternalGitPath s)+		| otherwise = s+#else+	gitpath = id+#endif+gitCommandLine _ repo = assertLocal repo $ error "internal"++{- Runs git in the specified repo. -}+runBool :: [CommandParam] -> Repo -> IO Bool+runBool params repo = assertLocal repo $+	boolSystemEnv "git"+		(gitCommandLine params repo)+		(gitEnv repo)++{- Runs git in the specified repo, throwing an error if it fails. -}+run :: [CommandParam] -> Repo -> IO ()+run params repo = assertLocal repo $+	unlessM (runBool params repo) $+		error $ "git " ++ show params ++ " failed"++{- Runs git and forces it to be quiet, throwing an error if it fails. -}+runQuiet :: [CommandParam] -> Repo -> IO ()+runQuiet params repo = withQuietOutput createProcessSuccess $+	(proc "git" $ toCommand $ gitCommandLine (params) repo)+		{ env = gitEnv repo }++{- 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+ - return True if it succeeded. Failure to wait will result in zombies.+ -}+pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool)+pipeReadLazy params repo = assertLocal repo $ do+	(_, Just h, _, pid) <- createProcess p { std_out = CreatePipe }+	fileEncoding h+	c <- hGetContents h+	return (c, checkSuccessProcess pid)+  where+	p  = gitCreateProcess params repo++{- Runs a git command, and returns its output, strictly.+ -+ - Nonzero exit status is ignored.+ -}+pipeReadStrict :: [CommandParam] -> Repo -> IO String+pipeReadStrict params repo = assertLocal repo $+	withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do+		fileEncoding h+		output <- hGetContentsStrict h+		hClose h+		return output+  where+	p  = gitCreateProcess params repo++{- Runs a git command, feeding it an input, and returning its output,+ - which is expected to be fairly small, since it's all read into memory+ - strictly. -}+pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String+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++{- 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++{- 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 params repo = do+	(s, cleanup) <- pipeReadLazy params repo+	return (filter (not . null) $ split sep s, cleanup)+  where+	sep = "\0"++pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String]+pipeNullSplitStrict params repo = do+	s <- pipeReadStrict params repo+	return $ filter (not . null) $ split sep s+  where+	sep = "\0"++pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]+pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo++{- Doesn't run the cleanup action. A zombie results. -}+leaveZombie :: (a, IO Bool) -> a+leaveZombie = fst++{- Runs a git command as a coprocess. -}+gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle+gitCoProcessStart restartable params repo = CoProcess.start restartable "git"+	(toCommand $ gitCommandLine params repo)+	(gitEnv repo)++gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess+gitCreateProcess params repo =+	(proc "git" $ toCommand $ gitCommandLine params repo)+			{ env = gitEnv repo }

@@ -0,0 +1,193 @@+{- git repository configuration handling+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Config where++import qualified Data.Map as M+import Data.Char+import System.Process (cwd, env)+import Control.Exception.Extensible++import Common+import Git+import Git.Types+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 list with each line of a multiline config setting. -}+getList :: String -> Repo -> [String]+getList key repo = M.findWithDefault [] key (fullconfig repo)++{- Returns a single git config setting, if set. -}+getMaybe :: String -> Repo -> Maybe String+getMaybe key repo = M.lookup key (config repo)++{- Runs git config and populates a repo with its config.+ - Avoids re-reading config when run repeatedly. -}+read :: Repo -> IO Repo+read repo@(Repo { config = c })+	| c == M.empty = read' repo+	| otherwise = return repo++{- Reads config even if it was read before. -}+reRead :: Repo -> IO Repo+reRead r = read' $ r+	{ config = M.empty+	, fullconfig = M.empty+	}++{- Cannot use pipeRead because it relies on the config having been already+ - read. Instead, chdir to the repo and run git config.+ -}+read' :: Repo -> IO Repo+read' repo = go repo+  where+	go Repo { location = Local { gitdir = d } } = git_config d+	go Repo { location = LocalUnknown d } = git_config d+	go _ = assertLocal repo $ error "internal"+	git_config d = withHandle StdoutHandle createProcessSuccess p $+		hRead repo+	  where+		params = ["config", "--null", "--list"]+		p = (proc "git" params)+			{ cwd = Just d+			, env = gitEnv repo+			}++{- Gets the global git config, returning a dummy Repo containing it. -}+global :: IO (Maybe Repo)+global = do+	home <- myHomeDir+	ifM (doesFileExist $ home </> ".gitconfig")+		( do+			repo <- Git.Construct.fromUnknown+			repo' <- withHandle StdoutHandle createProcessSuccess p $+				hRead repo+			return $ Just repo'+		, return Nothing+		)+  where+	params = ["config", "--null", "--list", "--global"]+	p = (proc "git" params)++{- 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+	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 repo = do+	let c = parse s+	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 }++{- Updates the location of a repo, based on its configuration.+ -+ - Git.Construct makes LocalUknown repos, of which only a directory is+ - known. Once the config is read, this can be fixed up to a Local repo, + - based on the core.bare and core.worktree settings.+ -}+updateLocation :: Repo -> IO Repo+updateLocation r@(Repo { location = LocalUnknown d })+	| isBare r = updateLocation' r $ Local d Nothing+	| otherwise = updateLocation' r $ Local (d </> ".git") (Just d)+updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l+updateLocation r = return r++updateLocation' :: Repo -> RepoLocation -> IO Repo+updateLocation' r l = do+	l' <- case getMaybe "core.worktree" r of+		Nothing -> return l+		Just d -> do+			{- core.worktree is relative to the gitdir -}+			top <- absPath $ gitdir l+			return $ l { worktree = Just $ absPathFrom top d }+	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+	-- --list output will have an = in the first line+	| all ('=' `elem`) (take 1 ls) = sep '=' ls+	-- --null --list output separates keys from values with newlines+	| otherwise = sep '\n' $ split "\0" s+  where+	ls = lines s+	sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .+		map (separate (== c))++{- Checks if a string from git config is a true value. -}+isTrue :: String -> Maybe Bool+isTrue s+	| s' == "true" = Just True+	| s' == "false" = Just False+	| otherwise = Nothing+  where+	s' = map toLower s++boolConfig :: Bool -> String+boolConfig True = "true"+boolConfig False = "false"++isBare :: Repo -> Bool+isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r++coreBare :: String+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 r cmd params = try $+	withHandle StdoutHandle createProcessSuccess p $ \h -> do+ 		fileEncoding h+		val <- hGetContentsStrict h+		r' <- store val r+		return (r', val)+  where+	p = proc cmd $ toCommand params++{- Reads git config from a specified file and returns the repo populated+ - with the configuration. -}+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))+fromFile r f = fromPipe r "git"+	[ Param "config"+	, Param "--file"+	, File f+	, Param "--list"+	]++{- 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"+	[ Param "config"+	, Param "--file"+	, File f+	, Param k+	, Param v+	]

@@ -0,0 +1,236 @@+{- Construction of Git Repo objects+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Git.Construct (+	fromCwd,+	fromAbsPath,+	fromPath,+	fromUrl,+	fromUnknown,+	localToUrl,+	remoteNamed,+	remoteNamedFromKey,+	fromRemotes,+	fromRemoteLocation,+	repoAbsPath,+	newFrom,+	checkForRepo,+) where++#ifndef mingw32_HOST_OS+import System.Posix.User+#endif+import qualified Data.Map as M hiding (map, split)+import Network.URI++import Common+import Git.Types+import Git+import Git.Remote+import qualified Git.Url as Url+import Utility.UserInfo++{- Finds the git repository used for the cwd, which may be in a parent+ - directory. -}+fromCwd :: IO (Maybe Repo)+fromCwd = getCurrentDirectory >>= seekUp+  where+	seekUp dir = do+		r <- checkForRepo dir+		case r of+			Nothing -> case parentDir dir of+				"" -> return Nothing+				d -> seekUp d+			Just loc -> Just <$> newFrom loc++{- Local Repo constructor, accepts a relative or absolute path. -}+fromPath :: FilePath -> IO Repo+fromPath dir = fromAbsPath =<< absPath dir++{- Local Repo constructor, requires an absolute path to the repo be+ - specified. -}+fromAbsPath :: FilePath -> IO Repo+fromAbsPath dir+	| isAbsolute dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )+	| otherwise =+		error $ "internal error, " ++ dir ++ " is not absolute"+  where+	ret = newFrom . LocalUnknown+	{- Git always looks for "dir.git" in preference to+	 - to "dir", even if dir ends in a "/". -}+	canondir = dropTrailingPathSeparator dir+	dir' = canondir ++ ".git"+	{- When dir == "foo/.git", git looks for "foo/.git/.git",+	 - and failing that, uses "foo" as the repository. -}+	hunt+		| (pathSeparator:".git") `isSuffixOf` canondir =+			ifM (doesDirectoryExist $ dir </> ".git")+				( ret dir+				, ret $ takeDirectory canondir+				)+		| otherwise = ret dir++{- Remote Repo constructor. Throws exception on invalid url.+ -+ - Git is somewhat forgiving about urls to repositories, allowing+ - eg spaces that are not normally allowed unescaped in urls.+ -}+fromUrl :: String -> IO Repo+fromUrl url+	| not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url+	| otherwise = fromUrlStrict url++fromUrlStrict :: String -> IO Repo+fromUrlStrict url+	| startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u+	| otherwise = newFrom $ Url u+  where+	u = fromMaybe bad $ parseURI url+	bad = error $ "bad url " ++ url++{- Creates a repo that has an unknown location. -}+fromUnknown :: IO Repo+fromUnknown = newFrom Unknown++{- Converts a local Repo into a remote repo, using the reference repo+ - which is assumed to be on the same host. -}+localToUrl :: Repo -> Repo -> Repo+localToUrl reference r+	| not $ repoIsUrl reference = error "internal error; reference repo not url"+	| repoIsUrl r = r+	| otherwise = case Url.authority reference of+		Nothing -> r+		Just auth -> +			let absurl = concat+				[ Url.scheme reference+				, "//"+				, auth+				, repoPath r+				]+			in r { location = Url $ fromJust $ parseURI absurl }++{- Calculates a list of a repo's configured remotes, by parsing its config. -}+fromRemotes :: Repo -> IO [Repo]+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++{- Sets the name of a remote when constructing the Repo to represent it. -}+remoteNamed :: String -> IO Repo -> IO Repo+remoteNamed n constructor = do+	r <- constructor+	return $ r { remoteName = Just n }++{- 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++{- Constructs a new Repo for one of a Repo's remotes using a given+ - location (ie, an url). -}+fromRemoteLocation :: String -> Repo -> IO Repo+fromRemoteLocation s repo = gen $ parseRemoteLocation s repo+  where+	gen (RemotePath p) = fromRemotePath p repo+	gen (RemoteUrl u) = fromUrl u++{- Constructs a Repo from the path specified in the git remotes of+ - another Repo. -}+fromRemotePath :: FilePath -> Repo -> IO Repo+fromRemotePath dir repo = do+	dir' <- expandTilde dir+	fromAbsPath $ repoPath repo </> dir'++{- Git remotes can have a directory that is specified relative+ - to the user's home directory, or that contains tilde expansions.+ - This converts such a directory to an absolute path.+ - Note that it has to run on the system where the remote is.+ -}+repoAbsPath :: FilePath -> IO FilePath+repoAbsPath d = do+	d' <- expandTilde d+	h <- myHomeDir+	return $ h </> d'++expandTilde :: FilePath -> IO FilePath+#ifdef mingw32_HOST_OS+expandTilde = return+#else+expandTilde = expandt True+  where+	expandt _ [] = return ""+	expandt _ ('/':cs) = do+		v <- expandt True cs+		return ('/':v)+	expandt True ('~':'/':cs) = do+		h <- myHomeDir+		return $ h </> cs+	expandt True ('~':cs) = do+		let (name, rest) = findname "" cs+		u <- getUserEntryForName name+		return $ homeDirectory u </> rest+	expandt _ (c:cs) = do+		v <- expandt False cs+		return (c:v)+	findname n [] = (n, "")+	findname n (c:cs)+		| c == '/' = (n, cs)+		| otherwise = findname (n++[c]) cs+#endif++{- Checks if a git repository exists in a directory. Does not find+ - git repositories in parent directories. -}+checkForRepo :: FilePath -> IO (Maybe RepoLocation)+checkForRepo dir = +	check isRepo $+		check gitDirFile $+			check isBareRepo $+				return Nothing+  where+	check test cont = maybe cont (return . Just) =<< test+	checkdir c = ifM c+		( return $ Just $ LocalUnknown dir+		, return Nothing+		)+	isRepo = checkdir $ gitSignature $ ".git" </> "config"+	isBareRepo = checkdir $ gitSignature "config"+		<&&> doesDirectoryExist (dir </> "objects")+	gitDirFile = do+		c <- firstLine <$>+			catchDefaultIO "" (readFile $ dir </> ".git")+		return $ if gitdirprefix `isPrefixOf` c+			then Just $ Local +				{ gitdir = absPathFrom dir $+					drop (length gitdirprefix) c+				, worktree = Just dir+				}+			else Nothing+	  where+		gitdirprefix = "gitdir: "+	gitSignature file = doesFileExist $ dir </> file++newFrom :: RepoLocation -> IO Repo+newFrom l = return Repo+	{ location = l+	, config = M.empty+	, fullconfig = M.empty+	, remotes = []+	, remoteName = Nothing+	, gitEnv = Nothing+	, gitGlobalOpts = []+	}++

@@ -0,0 +1,67 @@+{- The current git repository.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Git.CurrentRepo where++import Common+import Git.Types+import Git.Construct+import qualified Git.Config+#ifndef mingw32_HOST_OS+import Utility.Env+#endif++{- Gets the current git repository.+ -+ - Honors GIT_DIR and GIT_WORK_TREE.+ - Both environment variables are unset, to avoid confusing other git+ - commands that also look at them. Instead, the Git module passes+ - --work-tree and --git-dir to git commands it runs.+ -+ - When GIT_WORK_TREE or core.worktree are set, changes the working+ - 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.+ -}+get :: IO Repo+get = do+	gd <- pathenv "GIT_DIR"+	r <- configure gd =<< fromCwd+	wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE"+	case wt of+		Nothing -> return r+		Just d -> do+			cwd <- getCurrentDirectory+			unless (d `dirContains` cwd) $+				setCurrentDirectory d+			return $ addworktree wt r+  where+#ifndef mingw32_HOST_OS+	pathenv s = do+		v <- getEnv s+		case v of+			Just d -> do+				void $ unsetEnv s+				Just <$> absPath d+			Nothing -> return Nothing+#else+	pathenv _ = return Nothing+#endif++	configure Nothing (Just r) = Git.Config.read r+	configure (Just d) _ = do+		absd <- absPath d+		cwd <- getCurrentDirectory+		r <- newFrom $ Local { gitdir = absd, worktree = Just cwd }+		Git.Config.read r+	configure Nothing Nothing = error "Not in a git repository."++	addworktree w r = changelocation r $+		Local { gitdir = gitdir (location r), worktree = w }+	changelocation r l = r { location = l }

@@ -0,0 +1,64 @@+{- git FilePath library+ -+ - Different git commands use different types of FilePaths to refer to+ - files in the repository. Some commands use paths relative to the+ - top of the repository even when run in a subdirectory. Adding some+ - types helps keep that straight.+ -+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Git.FilePath (+	TopFilePath,+	fromTopFilePath,+	getTopFilePath,+	toTopFilePath,+	asTopFilePath,+	InternalGitPath,+	toInternalGitPath,+	fromInternalGitPath+) where++import Common+import Git++{- A FilePath, relative to the top of the git repository. -}+newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }+	deriving (Show)++{- Returns an absolute FilePath. -}+fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath+fromTopFilePath p repo = absPathFrom (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) <$> absPath file++{- The input FilePath must already be relative to the top of the git+ - repository -}+asTopFilePath :: FilePath -> TopFilePath+asTopFilePath file = TopFilePath file++{- Git may use a different representation of a path when storing+ - it internally. For example, on Windows, git uses '/' to separate paths+ - stored in the repository, despite Windows using '\' -}+type InternalGitPath = String++toInternalGitPath :: FilePath -> InternalGitPath+#ifndef mingw32_HOST_OS+toInternalGitPath = id+#else+toInternalGitPath = replace "\\" "/"+#endif++fromInternalGitPath :: InternalGitPath -> FilePath+#ifndef mingw32_HOST_OS+fromInternalGitPath = id+#else+fromInternalGitPath = replace "/" "\\"+#endif

@@ -0,0 +1,28 @@+{- Some git commands output encoded filenames, in a rather annoyingly complex+ - C-style encoding.+ -+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Filename where++import Utility.Format (decode_c, encode_c)++import Common++decode :: String -> FilePath+decode [] = []+decode f@(c:s)+	-- encoded strings will be inside double quotes+	| c == '"' && end s == ['"'] = decode_c $ beginning s+	| otherwise = f++{- Should not need to use this, except for testing decode. -}+encode :: FilePath -> String+encode s = "\"" ++ encode_c s ++ "\""++{- for quickcheck -}+prop_idempotent_deencode :: String -> Bool+prop_idempotent_deencode s = s == decode (encode s)

@@ -0,0 +1,87 @@+{- git fsck interface+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Fsck (+	FsckResults,+	MissingObjects,+	findBroken,+	foundBroken,+	findMissing,+) where++import Common+import Git+import Git.Command+import Git.Sha+import Git.CatFile+import Utility.Batch++import qualified Data.Set as S++type MissingObjects = S.Set Sha++{- If fsck succeeded, Just a set of missing objects it found.+ - If it failed, Nothing. -}+type FsckResults = Maybe MissingObjects++{- 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.+ -+ - Strategy: Rather than parsing fsck's current specific output,+ - look for anything in its output (both stdout and stderr) that appears+ - to be a git sha. Not all such shas are of broken objects, so ask git+ - to try to cat the object, and see if it fails.+ -}+findBroken :: Bool -> Repo -> IO FsckResults+findBroken batchmode r = do+	(output, fsckok) <- processTranscript command' (toCommand params') Nothing+	let objs = parseFsckOutput output+	badobjs <- findMissing objs r+	if S.null badobjs && not fsckok+		then return Nothing+		else return $ Just badobjs+  where+	(command, params) = ("git", fsckParams r)+	(command', params')+		| batchmode = toBatchCommand (command, params)+		| otherwise = (command, params)++foundBroken :: FsckResults -> Bool+foundBroken Nothing = True+foundBroken (Just s) = not (S.null s)++{- Finds objects that are missing from the git repsitory, or are corrupt.+ -+ - Note that catting a corrupt object will cause cat-file to crash;+ - this is detected and it's restarted.+ -}+findMissing :: [Sha] -> Repo -> IO MissingObjects+findMissing objs r = go objs [] =<< start+  where+	start = catFileStart' False r+	go [] c h = do+		catFileStop h+		return $ S.fromList c+	go (o:os) c h = do+		v <- tryIO $ isNothing <$> catObjectDetails h o+		case v of+			Left _ -> do+				void $ tryIO $ catFileStop h+				go os (o:c) =<< start+			Right True -> go os (o:c) h+			Right False -> go os c h++parseFsckOutput :: String -> [Sha]+parseFsckOutput = catMaybes . map extractSha . concat . map words . lines++fsckParams :: Repo -> [CommandParam]+fsckParams = gitCommandLine+	[ Param "fsck"+	, Param "--no-dangling"+	, Param "--no-reflogs"+	]

@@ -0,0 +1,214 @@+{- git ls-files interface+ -+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.LsFiles (+	inRepo,+	notInRepo,+	allFiles,+	deleted,+	modified,+	modifiedOthers,+	staged,+	stagedNotDeleted,+	stagedOthersDetails,+	stagedDetails,+	typeChanged,+	typeChangedStaged,+	Conflicting(..),+	Unmerged(..),+	unmerged,+	StagedDetails,+) where++import Common+import Git+import Git.Command+import Git.Types+import Git.Sha++import Numeric+import System.Posix.Types++{- Scans for files that are checked into git at the specified locations. -}+inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)+inRepo l = pipeNullSplit $ Params "ls-files --cached -z --" : map File l++{- 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+  where+	params = [Params "ls-files --others"] ++ exclude +++		[Params "-z --"] ++ map File l+	exclude+		| include_ignored = []+		| otherwise = [Param "--exclude-standard"]++{- Finds all files in the specified locations, whether checked into git or+ - not. -}+allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)+allFiles l = pipeNullSplit $ Params "ls-files --cached --others -z --" : map File 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+  where+	params = [Params "ls-files --deleted -z --"] ++ map File 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+  where+	params = [Params "ls-files --modified -z --"] ++ map File l++{- Files that have been modified or are not checked into git. -}+modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)+modifiedOthers l repo = pipeNullSplit params repo+  where+	params = [Params "ls-files --modified --others -z --"] ++ map File l++{- Returns a list of all files that are staged for commit. -}+staged :: [FilePath] -> Repo -> IO ([FilePath], 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 = staged' [Param "--diff-filter=ACMRT"]++staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)+staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix+  where+	prefix = [Params "diff --cached --name-only -z"]+	suffix = Param "--" : map File l++type StagedDetails = (FilePath, 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 = stagedDetails' [Params "--others --exclude-standard"]++{- Returns details about all files that are staged in the index. -}+stagedDetails :: [FilePath] -> 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' ps l repo = do+	(ls, cleanup) <- pipeNullSplit params repo+	return (map parse ls, cleanup)+  where+	params = Params "ls-files --stage -z" : ps ++ +		Param "--" : map File l+	parse s+		| null file = (s, Nothing, Nothing)+		| otherwise = (file, extractSha $ take shaSize rest, readmode mode)+	  where+		(metadata, file) = separate (== '\t') 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 = 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 = typeChanged' []++typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], 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.+	let top = repoPath repo+	cwd <- getCurrentDirectory+	return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup)+  where+	prefix = [Params "diff --name-only --diff-filter=T -z"]+	suffix = Param "--" : (if null l then [File "."] else map File l)++{- A item in conflict has two possible values.+ - Either can be Nothing, when that side deleted the file. -}+data Conflicting v = Conflicting+	{ valUs :: Maybe v+	, valThem :: Maybe v+	} deriving (Show)++data Unmerged = Unmerged+	{ unmergedFile :: FilePath+	, unmergedBlobType :: Conflicting BlobType+	, unmergedSha :: Conflicting Sha+	} deriving (Show)++{- Returns a list of the files in the specified locations that have+ - unresolved merge conflicts.+ -+ - ls-files outputs multiple lines per conflicting file, each with its own+ - stage number:+ -   1 = old version, can be ignored+ -   2 = us+ -   3 = them+ - If a line is omitted, that side removed the file.+ -}+unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool)+unmerged l repo = do+	(fs, cleanup) <- pipeNullSplit params repo+	return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)+  where+	params = Params "ls-files --unmerged -z --" : map File l++data InternalUnmerged = InternalUnmerged+	{ isus :: Bool+	, ifile :: FilePath+	, iblobtype :: Maybe BlobType+	, isha :: Maybe Sha+	} deriving (Show)++parseUnmerged :: String -> Maybe InternalUnmerged+parseUnmerged s+	| null file = Nothing+	| otherwise = case words metadata of+		(rawblobtype:rawsha:rawstage:_) -> do+			stage <- readish rawstage :: Maybe Int+			unless (stage == 2 || stage == 3) $+				fail undefined -- skip stage 1+			blobtype <- readBlobType rawblobtype+			sha <- extractSha rawsha+			return $ InternalUnmerged (stage == 2) file+				(Just blobtype) (Just sha)+		_ -> Nothing+  where+	(metadata, file) = separate (== '\t') s++reduceUnmerged :: [Unmerged] -> [InternalUnmerged] -> [Unmerged]+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)+	new = Unmerged+		{ unmergedFile = ifile i+		, unmergedBlobType = Conflicting blobtypeA blobtypeB+		, unmergedSha = Conflicting shaA shaB+		}+	findsib templatei [] = ([], removed templatei)+	findsib templatei (l:ls)+		| ifile l == ifile templatei = (ls, l)+		| otherwise = (l:ls, removed templatei)+	removed templatei = templatei+		{ isus = not (isus templatei)+		, iblobtype = Nothing+		, isha = Nothing+		}

@@ -0,0 +1,65 @@+{- git ls-tree interface+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.LsTree (+	TreeItem(..),+	lsTree,+	lsTreeParams,+	lsTreeFiles,+	parseLsTree+) where++import Numeric+import Control.Applicative+import System.Posix.Types++import Common+import Git+import Git.Command+import Git.Sha+import Git.FilePath+import qualified Git.Filename++data TreeItem = TreeItem+	{ mode :: FileMode+	, typeobj :: String+	, sha :: String+	, 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++lsTreeParams :: Ref -> [CommandParam]+lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ show t ]++{- Lists specified files in a tree. -}+lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]+lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo+  where+  	ps = [Params "ls-tree --full-tree -z --", File $ show t] ++ map File fs++{- Parses a line of ls-tree output.+ - (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

@@ -0,0 +1,29 @@+{- .git/objects+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Objects where++import Common+import Git++objectsDir :: Repo -> FilePath+objectsDir r = localGitDir r </> "objects"++packDir :: Repo -> FilePath+packDir r = objectsDir r </> "pack"++listPackFiles :: Repo -> IO [FilePath]+listPackFiles r = filter (".pack" `isSuffixOf`) +	<$> catchDefaultIO [] (dirContents $ packDir r)++packIdxFile :: FilePath -> FilePath+packIdxFile = flip replaceExtension "idx"++looseObjectFile :: Repo -> Sha -> FilePath+looseObjectFile r sha = objectsDir r </> prefix </> rest+  where+	(prefix, rest) = splitAt 2 (show sha)

@@ -0,0 +1,133 @@+{- git ref stuff+ -+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Ref where++import Common+import Git+import Git.Command++import Data.Char (chr)++headRef :: Ref+headRef = Ref "HEAD"++{- Converts a fully qualified git ref into a user-visible string. -}+describe :: Ref -> String+describe = show . base++{- Often git refs are fully qualified (eg: refs/heads/master).+ - Converts such a fully qualified ref into a base ref (eg: master). -}+base :: Ref -> Ref+base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show+  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 $ show r)++{- 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,+ - such as refs/remotes/origin/master. -}+underBase :: String -> Ref -> Ref+underBase dir r = Ref $ dir ++ "/" ++ show (base r)++{- 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++{- 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 r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)++{- Checks if a ref exists. -}+exists :: Ref -> Repo -> IO Bool+exists ref = runBool+	[Param "show-ref", Param "--verify", Param "-q", Param $ show ref]++{- 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 </> show 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++{- 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 $ show branch]+	process [] = Nothing+	process s = Just $ Ref $ firstLine s++{- List of (shas, branches) matching a given ref or refs. -}+matching :: [Ref] -> Repo -> IO [(Sha, Branch)]+matching refs repo =  matching' (map show refs) repo++{- Includes HEAD in the output, if asked for it. -}+matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]+matchingWithHEAD refs repo = matching' ("--head" : map show refs) repo++{- List of (shas, branches) matching a given ref or refs. -}+matching' :: [String] -> Repo -> IO [(Sha, Branch)]+matching' ps repo = map gen . lines <$> +	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.+ - 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++{- Checks if a String is a legal git ref name.+ -+ - The rules for this are complex; see git-check-ref-format(1) -}+legal :: Bool -> String -> Bool+legal allowonelevel s = all (== False) illegal+  where+	illegal =+		[ any ("." `isPrefixOf`) pathbits+		, any (".lock" `isSuffixOf`) pathbits+		, not allowonelevel && length pathbits < 2+		, contains ".."+		, any (\c -> contains [c]) illegalchars+		, begins "/"+		, ends "/"+		, contains "//"+		, ends "."+		, contains "@{"+		, null s+		]+	contains v = v `isInfixOf` s+	ends v = v `isSuffixOf` s+	begins v = v `isPrefixOf` s++	pathbits = split "/" s+	illegalchars = " ~^:?*[\\" ++ controlchars+	controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]

@@ -0,0 +1,22 @@+{- git reflog interface+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.RefLog where++import Common+import Git+import Git.Command+import Git.Sha++{- Gets the reflog for a given branch. -}+get :: Branch -> Repo -> IO [Sha]+get b = mapMaybe extractSha . lines <$$> pipeReadStrict+	[ Param "log"+	, Param "-g"+	, Param "--format=%H"+	, Param (show b)+	]

@@ -0,0 +1,115 @@+{- git remote stuff+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Git.Remote where++import Common+import Git+import Git.Types+import qualified Git.Command+import qualified Git.BuildVersion++import Data.Char+import qualified Data.Map as M+import Network.URI+#ifdef mingw32_HOST_OS+import Git.FilePath+#endif++{- 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,+ - just some ad-hoc checks, and some other things that fail with certian+ - types of names (like ones starting with '-').+ -}+makeLegalName :: String -> RemoteName+makeLegalName s = case filter legal $ replace "/" "_" s of+	-- it can't be empty+	[] -> "unnamed"+	-- it can't start with / or - or .+	'.':s' -> makeLegalName s'+	'/':s' -> makeLegalName s'+	'-':s' -> makeLegalName s'+	s' -> s'+  where+	{- Only alphanumerics, and a few common bits of punctuation common+	 - in hostnames. -}+	legal '_' = True+	legal '.' = True+	legal c = isAlphaNum c+	+remove :: RemoteName -> Repo -> IO ()+remove remotename = Git.Command.run+	[ Param "remote"+	-- name of this subcommand changed+	, Param $+		if Git.BuildVersion.older "1.8.0"+			then "rm"+			else "remove"+	, Param remotename+	]++data RemoteLocation = RemoteUrl String | RemotePath FilePath++remoteLocationIsUrl :: RemoteLocation -> Bool+remoteLocationIsUrl (RemoteUrl _) = True+remoteLocationIsUrl _ = False++remoteLocationIsSshUrl :: RemoteLocation -> Bool+remoteLocationIsSshUrl (RemoteUrl u) = "ssh://" `isPrefixOf` u+remoteLocationIsSshUrl _ = False++{- Determines if a given remote location is an url, or a local+ - path. Takes the repository's insteadOf configuration into account. -}+parseRemoteLocation :: String -> Repo -> RemoteLocation+parseRemoteLocation s repo = ret $ calcloc s+  where+  	ret v+#ifdef mingw32_HOST_OS+		| dosstyle v = RemotePath (dospath v)+#endif+		| scpstyle v = RemoteUrl (scptourl v)+		| urlstyle v = RemoteUrl v+		| otherwise = RemotePath v+	-- insteadof config can rewrite remote location+	calcloc l+		| null insteadofs = l+		| otherwise = replacement ++ drop (length bestvalue) l+	  where+		replacement = drop (length prefix) $+			take (length bestkey - length suffix) bestkey+		(bestkey, bestvalue) = maximumBy longestvalue insteadofs+		longestvalue (_, a) (_, b) = compare b a+		insteadofs = filterconfig $ \(k, v) -> +			startswith prefix k &&+			endswith suffix k &&+			startswith v l+		filterconfig f = filter f $+			concatMap splitconfigs $ M.toList $ fullconfig repo+		splitconfigs (k, vs) = map (\v -> (k, v)) vs+		(prefix, suffix) = ("url." , ".insteadof")+	urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v+	-- git remotes can be written scp style -- [user@]host:dir+	-- but foo::bar is a git-remote-helper location instead+	scpstyle v = ":" `isInfixOf` v +		&& not ("//" `isInfixOf` v)+		&& not ("::" `isInfixOf` v)+	scptourl v = "ssh://" ++ host ++ slash dir+	  where+		(host, dir) = separate (== ':') v+		slash d	| d == "" = "/~/" ++ d+			| "/" `isPrefixOf` d = d+			| "~" `isPrefixOf` d = '/':d+			| otherwise = "/~/" ++ d+#ifdef mingw32_HOST_OS+	-- 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+#endif

@@ -0,0 +1,534 @@+{- git repository recovery+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Repair (+	runRepair,+	runRepairOf,+	cleanCorruptObjects,+	retrieveMissingObjects,+	resetLocalBranches,+	removeTrackingBranches,+	checkIndex,+	missingIndex,+	nukeIndex,+	emptyGoodCommits,+) where++import Common+import Git+import Git.Command+import Git.Objects+import Git.Sha+import Git.Types+import Git.Fsck+import qualified Git.Config as Config+import qualified Git.Construct as Construct+import qualified Git.LsTree as LsTree+import qualified Git.LsFiles as LsFiles+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.Rsync++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, removes all+ - corrupt objects, and returns a list of missing objects,+ - which need to be found elsewhere to finish recovery.+ -+ - Since git fsck may crash on corrupt objects, and so not+ - report the full set of corrupt or missing objects,+ - this removes corrupt objects, and re-runs fsck, until it+ - stabalizes.+ -+ - To remove corrupt objects, unpack all packs, and remove the packs+ - (to handle corrupt packs), and remove loose object files.+ -}+cleanCorruptObjects :: FsckResults -> Repo -> IO MissingObjects+cleanCorruptObjects mmissing r = check mmissing+  where+	check Nothing = do+		putStrLn "git fsck found a problem but no specific broken objects. Perhaps a corrupt pack file?"+		ifM (explodePacks r)+			( retry S.empty+			, return S.empty+			)+	check (Just bad)+		| S.null bad = return S.empty+		| otherwise = do+			putStrLn $ unwords +				[ "git fsck found"+				, show (S.size bad)+				, "broken objects."+				]+			exploded <- explodePacks r+			removed <- removeLoose r bad+			if exploded || removed+				then retry bad+				else return bad+	retry oldbad = do+		putStrLn "Re-running git fsck to see if it finds more problems."+		v <- findBroken False r+		case v of+			Nothing -> error $ unwords+				[ "git fsck found a problem, which was not corrected after removing"+				, show (S.size oldbad)+				, "corrupt objects."+				]+			Just newbad -> do+				removed <- removeLoose r newbad+				let s = S.union oldbad newbad+				if not removed || s == oldbad+					then return s+					else retry s++removeLoose :: Repo -> MissingObjects -> IO Bool+removeLoose r s = do+	let fs = map (looseObjectFile r) (S.toList s)+	count <- length <$> filterM doesFileExist fs+	if (count > 0)+		then do+			putStrLn $ unwords+				[ "removing"+				, show count+				, "corrupt loose objects"+				]+			mapM_ nukeFile fs+			return True+		else return False++explodePacks :: Repo -> IO Bool+explodePacks r = do+	packs <- listPackFiles r+	if null packs+		then return False+		else do+			putStrLn "Unpacking all pack files."+			mapM_ go packs+			return True+  where+	go packfile = do+		-- May fail, if pack file is corrupt.+		void $ tryIO $+			pipeWrite [Param "unpack-objects"] r $ \h ->+				L.hPut h =<< L.readFile packfile+		nukeFile packfile+		nukeFile $ packIdxFile packfile++{- Try to retrieve a set of missing objects, from the remotes of a+ - repository. Returns any that could not be retreived.+ - + - If another clone of the repository exists locally, which might not be a+ - remote of the repo being repaired, its path can be passed as a reference+ - repository.+ -}+retrieveMissingObjects :: MissingObjects -> Maybe FilePath -> Repo -> IO MissingObjects+retrieveMissingObjects missing referencerepo r+	| S.null missing = return missing+	| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do+		unlessM (boolSystem "git" [Params "init", File tmpdir]) $+			error $ "failed to create temp repository in " ++ tmpdir+		tmpr <- Config.read =<< Construct.fromAbsPath tmpdir+		stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing+		if S.null stillmissing+			then return stillmissing+			else pullremotes tmpr (remotes r) fetchallrefs stillmissing+  where+	pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of+		Nothing -> return stillmissing+		Just p -> ifM (fetchfrom p fetchrefs tmpr)+			( do+				void $ copyObjects tmpr r+				findMissing (S.toList stillmissing) r+			, return stillmissing+			)+	pullremotes tmpr (rmt:rmts) fetchrefs s+		| S.null s = return s+		| otherwise = do+			putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt+			ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr)+				( do+					void $ copyObjects tmpr r+					stillmissing <- findMissing (S.toList s) r+					pullremotes tmpr rmts fetchrefs stillmissing+				, do+					putStrLn $ unwords+						[ "failed to fetch from remote"+						, repoDescribe rmt+						, "(will continue without it, but making this remote available may improve recovery)"+						]+					pullremotes tmpr rmts fetchrefs s+				)+	fetchfrom fetchurl ps = runBool $+		[ Param "fetch"+		, Param fetchurl+		, Params "--force --update-head-ok --quiet"+		] ++ ps+	-- fetch refs and tags+	fetchrefstags = [ Param "+refs/heads/*:refs/heads/*", Param "--tags"]+	-- Fetch all available refs (more likely to fail,+	-- as the remote may have refs it refuses to send).+	fetchallrefs = [ Param "+*:*" ]++{- Copies all objects from the src repository to the dest repository.+ - This is done using rsync, so it copies all missing object, and all+ - objects they rely on. -}+copyObjects :: Repo -> Repo -> IO Bool+copyObjects srcr destr = rsync+	[ Param "-qr"+	, File $ addTrailingPathSeparator $ objectsDir srcr+	, File $ addTrailingPathSeparator $ objectsDir destr+	]++{- To deal with missing objects that cannot be recovered, resets any+ - local branches to point to an old commit before the missing+ - objects. Returns all branches that were changed, and deleted.+ -}+resetLocalBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], [Branch], GoodCommits)+resetLocalBranches missing goodcommits r =+	go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r+  where+	islocalbranch b = "refs/heads/" `isPrefixOf` show b+	go changed deleted gcs [] = return (changed, deleted, gcs)+	go changed deleted gcs (b:bs) = do+		(mc, gcs') <- findUncorruptedCommit missing gcs b r+		case mc of+			Just c+				| c == b -> go changed deleted gcs' bs+				| otherwise -> do+					reset b c+					go (b:changed) deleted gcs' bs+			Nothing -> do+				nukeBranchRef b r+				go changed (b:deleted) gcs' bs+	reset b c = do+		nukeBranchRef b	r+		void $ runBool+			[ Param "branch"+			, Param (show $ Ref.base b)+			, Param (show c)+			] r++{- To deal with missing objects that cannot be recovered, removes+ - any remote tracking branches that reference them. Returns a list of+ - all removed branches.+ -}+removeTrackingBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], GoodCommits)+removeTrackingBranches missing goodcommits r =+	go [] goodcommits =<< filter istrackingbranch <$> getAllRefs r+  where+  	istrackingbranch b = "refs/remotes/" `isPrefixOf` show b+	go removed gcs [] = return (removed, gcs)+	go removed gcs (b:bs) = do+		(ok, gcs') <- verifyCommit missing gcs b r+		if ok+			then go removed gcs' bs+			else do+				nukeBranchRef b r+				go (b:removed) gcs' bs++{- Gets all refs, including ones that are corrupt.+ - git show-ref does not output refs to commits that are directly+ - corrupted, so it is not used.+ -}+getAllRefs :: Repo -> IO [Ref]+getAllRefs r = do+	packedrs <- mapMaybe parsePacked . lines+		<$> catchDefaultIO "" (readFile $ packedRefsFile r)+	loosers <- map toref <$> dirContentsRecursive refdir+	return $ packedrs ++ loosers+  where+  	refdir = localGitDir r </> "refs"+	toref = Ref . relPathDirToFile (localGitDir r)++packedRefsFile :: Repo -> FilePath+packedRefsFile r = localGitDir r </> "packed-refs"++parsePacked :: String -> Maybe Ref+parsePacked l = case words l of+	(sha:ref:[])+		| isJust (extractSha sha) -> Just $ Ref ref+	_ -> Nothing++{- git-branch -d cannot be used to remove a branch that is directly+ - pointing to a corrupt commit. However, it's tried first. -}+nukeBranchRef :: Branch -> Repo -> IO ()+nukeBranchRef b r = void $ usegit <||> byhand+  where+	usegit = runBool+		[ Param "branch"+		, Params "-r -d"+		, Param $ show $ Ref.base b+		] r+	byhand = do+		nukeFile $ localGitDir r </> show b+		whenM (doesFileExist packedrefs) $+			withTmpFile "packed-refs" $ \tmp h -> do+				ls <- lines <$> readFile packedrefs+				hPutStr h $ unlines $+					filter (not . skiprefline) ls+				hClose h+				renameFile tmp packedrefs+		return True+	skiprefline l = case parsePacked l of+		Just packedref+			| packedref == b -> True+		_ -> False+	packedrefs = packedRefsFile r++{- 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.+ - Otherwise, tries to traverse the commits in the branch to find one+ - that is ok. That might fail, if one of them is corrupt, or if an object+ - at the root of the branch is missing. Finally, looks for an old version+ - of the branch from the reflog.+ -}+findUncorruptedCommit :: MissingObjects -> GoodCommits -> Branch -> Repo -> IO (Maybe Sha, GoodCommits)+findUncorruptedCommit missing goodcommits branch r = do+	(ok, goodcommits') <- verifyCommit missing goodcommits branch r+	if ok+		then return (Just branch, goodcommits')+		else do+			(ls, cleanup) <- pipeNullSplit+				[ Param "log"+				, Param "-z"+				, Param "--format=%H"+				, Param (show branch)+				] r+			let branchshas = catMaybes $ map extractSha ls+			reflogshas <- RefLog.get branch r+			-- XXX Could try a bit harder here, and look+			-- for uncorrupted old commits in branches in the+			-- reflog.+			cleanup `after` findfirst goodcommits (branchshas ++ reflogshas)+  where+	findfirst gcs [] = return (Nothing, gcs)+	findfirst gcs (c:cs) = do+		(ok, gcs') <- verifyCommit missing gcs c r+		if ok+			then return (Just c, gcs')+			else findfirst gcs' cs++{- Verifies tha none of the missing objects in the set are used by+ - the commit. Also adds to a set of commit shas that have been verified to+ - be good, which can be passed into subsequent calls to avoid+ - redundant work when eg, chasing down branches to find the first+ - uncorrupted commit. -}+verifyCommit :: MissingObjects -> GoodCommits -> Sha -> Repo -> IO (Bool, GoodCommits)+verifyCommit missing goodcommits commit r+	| checkGoodCommit commit goodcommits = return (True, goodcommits)+	| otherwise = do+		(ls, cleanup) <- pipeNullSplit+			[ Param "log"+			, Param "-z"+			, Param "--format=%H %T"+			, Param (show commit)+			] r+		let committrees = map parse ls+		if any isNothing committrees || null committrees+			then do+				void cleanup+				return (False, goodcommits)+			else do+				let cts = catMaybes committrees+				ifM (cleanup <&&> check cts)+					( return (True, addGoodCommits (map fst cts) goodcommits)+					, return (False, goodcommits)+					)+  where+	parse l = case words l of+		(commitsha:treesha:[]) -> (,)+			<$> extractSha commitsha+			<*> extractSha treesha+		_ -> Nothing+	check [] = return True+	check ((c, t):rest)+		| checkGoodCommit c goodcommits = return True+		| otherwise = verifyTree missing t r <&&> check rest++{- Verifies that a tree is good, including all trees and blobs+ - referenced by it. -}+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)+			then do+				void cleanup+				return False+			-- as long as ls-tree succeeded, we're good+			else cleanup++{- Checks that the index file only refers to objects that are not missing,+ - and is not itself corrupt. Note that a missing index file is not+ - considered a problem (repo may be new). -}+checkIndex :: MissingObjects -> Repo -> IO Bool+checkIndex missing r = do+	(bad, _good, cleanup) <- partitionIndex missing r+	if null bad+		then cleanup+		else do+			void cleanup+			return False++missingIndex :: Repo -> IO Bool+missingIndex r = not <$> doesFileExist (localGitDir r </> "index")++partitionIndex :: MissingObjects -> Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)+partitionIndex missing r = do+	(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r+	let (bad, good) = partition ismissing indexcontents+	return (bad, good, cleanup)+  where+	getblob (_file, Just sha, Just _mode) = Just sha+	getblob _ = Nothing+	ismissing = maybe False (`S.member` missing) . getblob++{- Rewrites the index file, removing from it any files whose blobs are+ - missing. Returns the list of affected files. -}+rewriteIndex :: MissingObjects -> Repo -> IO [FilePath]+rewriteIndex missing r+	| repoIsLocalBare r = return []+	| otherwise = do+		(bad, good, cleanup) <- partitionIndex missing r+		unless (null bad) $ do+			nukeIndex r+			UpdateIndex.streamUpdateIndex r+				=<< (catMaybes <$> mapM reinject good)+		void cleanup+		return $ map fst3 bad+  where+	reinject (file, Just sha, Just mode) = case toBlobType mode of+		Nothing -> return Nothing+		Just blobtype -> Just <$>+			UpdateIndex.stageFile sha blobtype file r+	reinject _ = return Nothing++nukeIndex :: Repo -> IO ()+nukeIndex r = nukeFile (localGitDir r </> "index")++newtype GoodCommits = GoodCommits (S.Set Sha)++emptyGoodCommits :: GoodCommits+emptyGoodCommits = GoodCommits S.empty++checkGoodCommit :: Sha -> GoodCommits -> Bool+checkGoodCommit sha (GoodCommits s) = S.member sha s++addGoodCommits :: [Sha] -> GoodCommits -> GoodCommits+addGoodCommits shas (GoodCommits s) = GoodCommits $+	S.union s (S.fromList shas)++displayList :: [String] -> String -> IO ()+displayList items header+	| null items = return ()+	| otherwise = do+		putStrLn header+		putStr $ unlines $ map (\i -> "\t" ++ i) truncateditems+  where+  	numitems = length items+	truncateditems+		| numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"]+		| otherwise = items++{- Put it all together. -}+runRepair :: Bool -> Repo -> IO (Bool, MissingObjects, [Branch])+runRepair forced g = do+	putStrLn "Running git fsck ..."+	fsckresult <- findBroken False g+	if foundBroken fsckresult+		then runRepairOf fsckresult forced Nothing g+		else do+			putStrLn "No problems found."+			return (True, S.empty, [])++runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])+runRepairOf fsckresult forced referencerepo g = do+	missing <- cleanCorruptObjects fsckresult g+	stillmissing <- retrieveMissingObjects missing referencerepo g+	if S.null stillmissing+		then if repoIsLocalBare g+			then successfulfinish stillmissing []+			else ifM (checkIndex stillmissing g)+				( successfulfinish stillmissing []+				, do+					putStrLn "No missing objects found, but the index file is corrupt!"+					if forced+						then corruptedindex+						else needforce stillmissing+				)		+		else do+			putStrLn $ unwords+				[ show (S.size stillmissing)+				, "missing objects could not be recovered!"+				]+			if forced+				then continuerepairs stillmissing+				else unsuccessfulfinish stillmissing+  where+	continuerepairs stillmissing = do+		(remotebranches, goodcommits) <- removeTrackingBranches stillmissing emptyGoodCommits g+		unless (null remotebranches) $+			putStrLn $ unwords+				[ "removed"+				, show (length remotebranches)+				, "remote tracking branches that referred to missing objects"+				]+		(resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g+		displayList (map show resetbranches)+			"Reset these local branches to old versions before the missing objects were committed:"+		displayList (map show deletedbranches)+			"Deleted these local branches, which could not be recovered due to missing objects:"+		deindexedfiles <- rewriteIndex stillmissing g+		displayList deindexedfiles+			"Removed these missing files from the index. You should look at what files are present in your working tree and git add them back to the index when appropriate."+		let modifiedbranches = resetbranches ++ deletedbranches+		if null resetbranches && null deletedbranches+			then successfulfinish stillmissing modifiedbranches+			else do+				unless (repoIsLocalBare g) $ do+					mcurr <- Branch.currentUnsafe g+					case mcurr of+						Nothing -> return ()+						Just curr -> when (any (== curr) modifiedbranches) $ do+							putStrLn $ unwords+								[ "You currently have"+								, show curr+								, "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!"+								]+				putStrLn "Successfully recovered repository!"+				putStrLn "Please carefully check that the changes mentioned above are ok.."+				return (True, stillmissing, modifiedbranches)+	+	corruptedindex = do+		nukeIndex g+		putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate."+		return (True, S.empty, [])++	successfulfinish stillmissing modifiedbranches = do+		mapM_ putStrLn+			[ "Successfully recovered repository!"+			, "You should run \"git fsck\" to make sure, but it looks like"+			, "everything was recovered ok."+			]+		return (True, stillmissing, modifiedbranches)+	unsuccessfulfinish stillmissing = do+		if repoIsLocalBare g+			then do+				putStrLn "If you have a clone of this bare repository, you should add it as a remote of this repository, and retry."+				putStrLn "If there are no clones of this repository, you can instead retry with the --force parameter to force recovery to a possibly usable state."+				return (False, stillmissing, [])+			else needforce stillmissing+	needforce stillmissing = do+		putStrLn "To force a recovery to a usable state, retry with the --force parameter."+		return (False, stillmissing, [])

@@ -0,0 +1,39 @@+{- git SHA stuff+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Sha where++import Common+import Git.Types++{- Runs an action that causes a git subcommand to emit a Sha, and strips+ - any trailing newline, returning the sha. -}+getSha :: String -> IO String -> IO Sha+getSha subcommand a = maybe bad return =<< extractSha <$> a+  where+	bad = error $ "failed to read sha from git " ++ subcommand++{- Extracts the Sha from a string. There can be a trailing newline after+ - it, but nothing else. -}+extractSha :: String -> Maybe Sha+extractSha s+	| len == shaSize = val s+	| len == shaSize + 1 && length s' == shaSize = val s'+	| otherwise = Nothing+  where+	len = length s+	s' = firstLine s+	val v+		| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v+		| otherwise = Nothing++{- Size of a git sha. -}+shaSize :: Int+shaSize = 40++nullSha :: Ref		+nullSha = Ref $ replicate shaSize '0'

@@ -0,0 +1,95 @@+{- git data types+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Types where++import Network.URI+import qualified Data.Map as M+import System.Posix.Types+import Utility.SafeCommand++{- Support repositories on local disk, and repositories accessed via an URL.+ -+ - Repos on local disk have a git directory, and unless bare, a worktree.+ -+ - A local repo may not have had its config read yet, in which case all+ - that's known about it is its path.+ -+ - Finally, an Unknown repository may be known to exist, but nothing+ - else known about it.+ -}+data RepoLocation+	= Local { gitdir :: FilePath, worktree :: Maybe FilePath }+	| LocalUnknown FilePath+	| Url URI+	| Unknown+	deriving (Show, Eq)++data Repo = Repo+	{ location :: RepoLocation+	, config :: M.Map String String+	-- 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+	, remoteName :: Maybe RemoteName+	-- alternate environment to use when running git commands+	, gitEnv :: Maybe [(String, String)]+	-- global options to pass to git when running git commands+	, gitGlobalOpts :: [CommandParam]+	} deriving (Show, Eq)++type RemoteName = String++{- A git ref. Can be a sha1, or a branch or tag name. -}+newtype Ref = Ref String+	deriving (Eq, Ord)++instance Show Ref where+	show (Ref v) = v++{- Aliases for Ref. -}+type Branch = Ref+type Sha = Ref+type Tag = Ref++{- 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 "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

@@ -0,0 +1,86 @@+{- git-update-index library+ -+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE BangPatterns, CPP #-}++module Git.UpdateIndex (+	Streamer,+	pureStreamer,+	streamUpdateIndex,+	lsTree,+	updateIndexLine,+	stageFile,+	unstageFile,+	stageSymlink+) where++import Common+import Git+import Git.Types+import Git.Command+import Git.FilePath+import Git.Sha++{- 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 ()++{- A streamer with a precalculated value. -}+pureStreamer :: String -> Streamer+pureStreamer !s = \streamer -> streamer s++{- Streams content into update-index from a list of Streamers. -}+streamUpdateIndex :: Repo -> [Streamer] -> IO ()+streamUpdateIndex repo as = pipeWrite params repo $ \h -> do+	fileEncoding h+	forM_ as (stream h)+	hClose h+  where+	params = map Param ["update-index", "-z", "--index-info"]+	stream h a = a (streamer h)+	streamer h s = do+		hPutStr h s+		hPutStr h "\0"++{- A streamer that adds the current tree for a ref. Useful for eg, copying+ - and modifying branches. -}+lsTree :: Ref -> Repo -> Streamer+lsTree (Ref x) repo streamer = do+	(s, cleanup) <- pipeNullSplit params repo+	mapM_ streamer s+	void $ cleanup+  where+	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]++{- 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 " ++ show 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++{- A streamer that removes a file from the index. -}+unstageFile :: FilePath -> Repo -> IO Streamer+unstageFile file repo = do+	p <- toTopFilePath file repo+	return $ pureStreamer $ "0 " ++ show 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+	return $ pureStreamer line++indexPath :: TopFilePath -> InternalGitPath+indexPath = toInternalGitPath . getTopFilePath

@@ -0,0 +1,71 @@+{- git repository urls+ -+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Url (+	scheme,+	host,+	port,+	hostuser,+	authority,+) where++import Network.URI hiding (scheme, authority)++import Common+import Git.Types+import Git++{- Scheme of an URL repo. -}+scheme :: Repo -> String+scheme Repo { location = Url u } = uriScheme u+scheme repo = notUrl repo++{- Work around a bug in the real uriRegName+ - <http://trac.haskell.org/network/ticket/40> -}+uriRegName' :: URIAuth -> String+uriRegName' a = fixup $ uriRegName a+  where+	fixup x@('[':rest)+		| rest !! len == ']' = take len rest+		| otherwise = x+	  where+		len  = length rest - 1+	fixup x = x++{- Hostname of an URL repo. -}+host :: Repo -> Maybe String+host = authpart uriRegName'++{- Port of an URL repo, if it has a nonstandard one. -}+port :: Repo -> Maybe Integer+port r = +	case authpart uriPort r of+		Nothing -> Nothing+		Just ":" -> Nothing+		Just (':':p) -> readish p+		Just _ -> Nothing++{- Hostname of an URL repo, including any username (ie, "user@host") -}+hostuser :: Repo -> Maybe String+hostuser r = (++)+	<$> authpart uriUserInfo r+	<*> authpart uriRegName' r++{- The full authority portion an URL repo. (ie, "user@host:port") -}+authority :: Repo -> Maybe String+authority = authpart assemble+  where+	assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a++{- Applies a function to extract part of the uriAuthority of an URL repo. -}+authpart :: (URIAuth -> a) -> Repo -> Maybe a+authpart a Repo { location = Url u } = a <$> uriAuthority u+authpart _ repo = notUrl repo++notUrl :: Repo -> a+notUrl repo = error $+	"acting on local git repo " ++ repoDescribe repo ++ " not supported"

@@ -0,0 +1,43 @@+{- git versions+ -+ - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Version where++import Common++data GitVersion = GitVersion String Integer+	deriving (Eq)++instance Ord GitVersion where+	compare (GitVersion _ x) (GitVersion _ y) = compare x y++instance Show GitVersion where+	show (GitVersion s _) = s++installed :: IO GitVersion+installed = normalize . extract <$> readProcess "git" ["--version"]+  where+  	extract s = case lines s of+		[] -> ""+		(l:_) -> unwords $ drop 2 $ words l++{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to+ - a somewhat arbitrary integer representation. -}+normalize :: String -> GitVersion+normalize v = GitVersion v $ +	sum $ mult 1 $ reverse $ extend precision $ take precision $+		map readi $ split "." v+  where+	extend n l = l ++ replicate (n - length l) 0+	mult _ [] = []+	mult n (x:xs) = (n*x) : mult (n*10^width) xs+	readi :: String -> Integer+	readi s = case reads s of+		((x,_):_) -> x+		_ -> 0+	precision = 10 -- number of segments of the version to compare+	width = length "yyyymmddhhmmss" -- maximum width of a segment

@@ -0,0 +1,31 @@+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+	@$(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++install: build+	install -d $(DESTDIR)$(PREFIX)/bin+	install git-repair $(DESTDIR)$(PREFIX)/bin+	install -d $(DESTDIR)$(PREFIX)/share/man/man1+	install -m 0644 git-repair.1 $(DESTDIR)$(PREFIX)/share/man/man1++clean:+	rm -rf git-repair dist configure Build/SysConfig.hs Setup tags+	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:+	find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null

@@ -0,0 +1,14 @@+{- cabal setup file -}++import Distribution.Simple+import Distribution.Simple.Setup++import qualified Build.Configure as Configure++main = defaultMainWithHooks simpleUserHooks+	{ preConf = configure+	}++configure _ _ = do+	Configure.run Configure.tests+	return (Nothing, [])

@@ -0,0 +1,16 @@+{- applicative stuff+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Applicative where++{- Like <$> , but supports one level of currying.+ - + - foo v = bar <$> action v  ==  foo = bar <$$> action+ -}+(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b+f <$$> v = fmap f . v+infixr 4 <$$>

@@ -0,0 +1,91 @@+{- Running a long or expensive batch operation niced.+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Batch where++import Common+#ifndef mingw32_HOST_OS+import qualified Build.SysConfig+#endif++#if defined(linux_HOST_OS) || defined(__ANDROID__)+import Control.Concurrent.Async+import System.Posix.Process+#endif+import qualified Control.Exception as E+import System.Process (env)++{- Runs an operation, at batch priority.+ -+ - This is done by running it in a bound thread, which on Linux can be set+ - to have a different nice level than the rest of the program. Note that+ - due to running in a bound thread, some operations may be more expensive+ - to perform. Also note that if the action calls forkIO or forkOS itself,+ - that will make a new thread that does not have the batch priority.+ -+ - POSIX threads do not support separate nice levels, so on other operating+ - systems, the action is simply ran.+ -}+batch :: IO a -> IO a+#if defined(linux_HOST_OS) || defined(__ANDROID__)+batch a = wait =<< batchthread+  where+  	batchthread = asyncBound $ do+		setProcessPriority 0 maxNice+		a+#else+batch a = a+#endif++maxNice :: Int+maxNice = 19++{- Converts a command to run niced. -}+toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam])+toBatchCommand (command, params) = (command', params')+  where+#ifndef mingw32_HOST_OS+	commandline = unwords $ map shellEscape $ command : toCommand params+	nicedcommand+		| Build.SysConfig.nice = "nice " ++ commandline+		| otherwise = commandline+	command' = "sh"+	params' =+		[ Param "-c"+		, Param $ "exec " ++ nicedcommand+		]+#else+	command' = command+	params' = params+#endif++{- Runs a command in a way that's suitable for batch jobs that can be+ - interrupted.+ -+ - The command is run niced. If the calling thread receives an async+ - exception, it sends the command a SIGTERM, and after the command+ - finishes shuttting down, it re-raises the async exception. -}+batchCommand :: String -> [CommandParam] -> IO Bool+batchCommand command params = batchCommandEnv command params Nothing++batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool+batchCommandEnv command params environ = do+	(_, _, _, pid) <- createProcess $ p { env = environ }+	r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode)+	case r of+		Right ExitSuccess -> return True+		Right _ -> return False+		Left asyncexception -> do+			terminateProcess pid+			void $ waitForProcess pid+			E.throwIO asyncexception+  where+  	(command', params') = toBatchCommand (command, params)+  	p = proc command' $ toCommand params'+

@@ -0,0 +1,93 @@+{- Interface for running a shell command as a coprocess,+ - sending it queries and getting back results.+ -+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.CoProcess (+	CoProcessHandle,+	start,+	stop,+	query,+	rawMode+) where++import Common++import Control.Concurrent.MVar++type CoProcessHandle = MVar CoProcessState++data CoProcessState = CoProcessState+	{ coProcessPid :: ProcessHandle+	, coProcessTo :: Handle+	, coProcessFrom :: Handle+	, coProcessSpec :: CoProcessSpec+	}++data CoProcessSpec = CoProcessSpec+	{ coProcessRestartable :: Bool+	, coProcessCmd :: FilePath+	, coProcessParams :: [String]+	, coProcessEnv :: Maybe [(String, String)]+	}++start :: Bool -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle+start restartable cmd params env = do+	s <- start' $ CoProcessSpec restartable cmd params env+	newMVar s++start' :: CoProcessSpec -> IO CoProcessState+start' s = do+	(pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s)+	return $ CoProcessState pid to from s++stop :: CoProcessHandle -> IO ()+stop ch = do+	s <- readMVar ch+	hClose $ coProcessTo s+	hClose $ coProcessFrom s+	let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s)+	forceSuccessProcess p (coProcessPid s)++{- To handle a restartable process, any IO exception thrown by the send and+ - receive actions are assumed to mean communication with the process+ - failed, and the failed action is re-run with a new process. -}+query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b+query ch send receive = do+	s <- readMVar ch+	restartable s (send $ coProcessTo s) $ const $+		restartable s (hFlush $ coProcessTo s) $ const $+			restartable s (receive $ coProcessFrom s) $+				return+  where+  	restartable s a cont+		| coProcessRestartable (coProcessSpec s) =+			maybe restart cont =<< catchMaybeIO a+		| otherwise = cont =<< a+	restart = do+		s <- takeMVar ch+		void $ catchMaybeIO $ do+			hClose $ coProcessTo s+			hClose $ coProcessFrom s+		void $ waitForProcess $ coProcessPid s+		s' <- start' (coProcessSpec s)+		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

@@ -0,0 +1,17 @@+{- utilities for simple data types+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Data where++{- First item in the list that is not Nothing. -}+firstJust :: Eq a => [Maybe a] -> Maybe a+firstJust ms = case dropWhile (== Nothing) ms of+	[] -> Nothing+	(md:_) -> md++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe = either (const Nothing) Just

@@ -0,0 +1,107 @@+{- directory manipulation+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Directory where++import System.IO.Error+import System.PosixCompat.Files+import System.Directory+import Control.Exception (throw)+import Control.Monad+import Control.Monad.IfElse+import System.FilePath+import Control.Applicative+import System.IO.Unsafe (unsafeInterleaveIO)++import Utility.SafeCommand+import Utility.Tmp+import Utility.Exception+import Utility.Monad++dirCruft :: FilePath -> Bool+dirCruft "." = True+dirCruft ".." = True+dirCruft _ = False++{- Lists the contents of a directory.+ - Unlike getDirectoryContents, paths are not relative to the directory. -}+dirContents :: FilePath -> IO [FilePath]+dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d++{- Gets files in a directory, and then its subdirectories, recursively,+ - and lazily. If the directory does not exist, no exception is thrown,+ - instead, [] is returned. -}+dirContentsRecursive :: FilePath -> IO [FilePath]+dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) topdir++{- Skips directories whose basenames match the skipdir. -}+dirContentsRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+dirContentsRecursiveSkipping skipdir topdir = go [topdir]+  where+  	go [] = return []+	go (dir:dirs)+		| skipdir (takeFileName dir) = go dirs+		| otherwise = unsafeInterleaveIO $ do+			(files, dirs') <- collect [] []+				=<< catchDefaultIO [] (dirContents dir)+			files' <- go (dirs' ++ dirs)+			return (files ++ files')+	collect files dirs' [] = return (reverse files, reverse dirs')+	collect files dirs' (entry:entries)+		| dirCruft entry = collect files dirs' entries+		| otherwise = do+			ifM (doesDirectoryExist entry)+				( collect files (entry:dirs') entries+				, collect (entry:files) dirs' entries+				)			++{- Moves one filename to another.+ - First tries a rename, but falls back to moving across devices if needed. -}+moveFile :: FilePath -> FilePath -> IO ()+moveFile src dest = tryIO (rename src dest) >>= onrename+  where+	onrename (Right _) = noop+	onrename (Left e)+		| isPermissionError e = rethrow+		| isDoesNotExistError e = rethrow+		| otherwise = do+			-- copyFile is likely not as optimised as+			-- the mv command, so we'll use the latter.+			-- But, mv will move into a directory if+			-- dest is one, which is not desired.+			whenM (isdir dest) rethrow+			viaTmp mv dest undefined+	  where+		rethrow = throw e+		mv tmp _ = do+			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]+			unless ok $ do+				-- delete any partial+				_ <- tryIO $ removeFile tmp+				rethrow++	isdir f = do+		r <- tryIO $ getFileStatus f+		case r of+			(Left _) -> return False+			(Right s) -> return $ isDirectory s++{- Removes a file, which may or may not exist, and does not have to+ - be a regular file.+ -+ - Note that an exception is thrown if the file exists but+ - cannot be removed. -}+nukeFile :: FilePath -> IO ()+nukeFile file = void $ tryWhenExists go+  where+#ifndef mingw32_HOST_OS+	go = removeLink file+#else+	go = removeFile file+#endif

@@ -0,0 +1,63 @@+{- portable environment variables+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Env where++#ifdef mingw32_HOST_OS+import Utility.Exception+import Control.Applicative+import Data.Maybe+import qualified System.Environment as E+#else+import qualified System.Posix.Env as PE+#endif++getEnv :: String -> IO (Maybe String)+#ifndef mingw32_HOST_OS+getEnv = PE.getEnv+#else+getEnv = catchMaybeIO . E.getEnv+#endif++getEnvDefault :: String -> String -> IO String+#ifndef mingw32_HOST_OS+getEnvDefault = PE.getEnvDefault+#else+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var+#endif++getEnvironment :: IO [(String, String)]+#ifndef mingw32_HOST_OS+getEnvironment = PE.getEnvironment+#else+getEnvironment = E.getEnvironment+#endif++{- Returns True if it could successfully set the environment variable.+ -+ - There is, apparently, no way to do this in Windows. Instead,+ - environment varuables must be provided when running a new process. -}+setEnv :: String -> String -> Bool -> IO Bool+#ifndef mingw32_HOST_OS+setEnv var val overwrite = do+	PE.setEnv var val overwrite+	return True+#else+setEnv _ _ _ = return False+#endif++{- Returns True if it could successfully unset the environment variable. -}+unsetEnv :: String -> IO Bool+#ifndef mingw32_HOST_OS+unsetEnv var = do+	PE.unsetEnv var+	return True+#else+unsetEnv _ = return False+#endif

@@ -0,0 +1,59 @@+{- Simple IO exception handling (and some more)+ -+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE ScopedTypeVariables #-}++module Utility.Exception where++import Control.Exception+import qualified Control.Exception as E+import Control.Applicative+import Control.Monad+import System.IO.Error (isDoesNotExistError)+import Utility.Data++{- Catches IO errors and returns a Bool -}+catchBoolIO :: IO Bool -> IO Bool+catchBoolIO a = catchDefaultIO False a++{- Catches IO errors and returns a Maybe -}+catchMaybeIO :: IO a -> IO (Maybe a)+catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a++{- Catches IO errors and returns a default value. -}+catchDefaultIO :: a -> IO a -> IO a+catchDefaultIO def a = catchIO a (const $ return def)++{- Catches IO errors and returns the error message. -}+catchMsgIO :: IO a -> IO (Either String a)+catchMsgIO a = either (Left . show) Right <$> tryIO a++{- catch specialized for IO errors only -}+catchIO :: IO a -> (IOException -> IO a) -> IO a+catchIO = E.catch++{- try specialized for IO errors only -}+tryIO :: IO a -> IO (Either IOException a)+tryIO = try++{- Catches all exceptions except for async exceptions.+ - This is often better to use than catching them all, so that+ - ThreadKilled and UserInterrupt get through.+ -}+catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a+catchNonAsync a onerr = a `catches`+	[ Handler (\ (e :: AsyncException) -> throw e)+	, Handler (\ (e :: SomeException) -> onerr e)+	]++tryNonAsync :: IO a -> IO (Either SomeException a)+tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)++{- Catches only DoesNotExist exceptions, and lets all others through. -}+tryWhenExists :: IO a -> IO (Maybe a)+tryWhenExists a = eitherToMaybe <$>+	tryJust (guard . isDoesNotExistError) a

@@ -0,0 +1,135 @@+{- File mode utilities.+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.FileMode where++import Common++import Control.Exception (bracket)+import System.PosixCompat.Types+#ifndef mingw32_HOST_OS+import System.Posix.Files+#endif+import Foreign (complement)++{- Applies a conversion function to a file's mode. -}+modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()+modifyFileMode f convert = void $ modifyFileMode' f convert+modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode+modifyFileMode' f convert = do+	s <- getFileStatus f+	let old = fileMode s+	let new = convert old+	when (new /= old) $+		setFileMode f new+	return old++{- Adds the specified FileModes to the input mode, leaving the rest+ - unchanged. -}+addModes :: [FileMode] -> FileMode -> FileMode+addModes ms m = combineModes (m:ms)++{- Removes the specified FileModes from the input mode. -}+removeModes :: [FileMode] -> FileMode -> FileMode+removeModes ms m = m `intersectFileModes` complement (combineModes ms)++{- Runs an action after changing a file's mode, then restores the old mode. -}+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a+withModifiedFileMode file convert a = bracket setup cleanup go+  where+	setup = modifyFileMode' file convert+	cleanup oldmode = modifyFileMode file (const oldmode)+	go _ = a++writeModes :: [FileMode]+writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]++readModes :: [FileMode]+readModes = [ownerReadMode, groupReadMode, otherReadMode]++executeModes :: [FileMode]+executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]++{- Removes the write bits from a file. -}+preventWrite :: FilePath -> IO ()+preventWrite f = modifyFileMode f $ removeModes writeModes++{- Turns a file's owner write bit back on. -}+allowWrite :: FilePath -> IO ()+allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]++{- Allows owner and group to read and write to a file. -}+groupWriteRead :: FilePath -> IO ()+groupWriteRead f = modifyFileMode f $ addModes+	[ ownerWriteMode, groupWriteMode+	, ownerReadMode, groupReadMode+	]++checkMode :: FileMode -> FileMode -> Bool+checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor++{- Checks if a file mode indicates it's a symlink. -}+isSymLink :: FileMode -> Bool+#ifdef mingw32_HOST_OS+isSymLink _ = False+#else+isSymLink = checkMode symbolicLinkMode+#endif++{- Checks if a file has any executable bits set. -}+isExecutable :: FileMode -> Bool+isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0++{- Runs an action without that pesky umask influencing it, unless the+ - passed FileMode is the standard one. -}+noUmask :: FileMode -> IO a -> IO a+#ifndef mingw32_HOST_OS+noUmask mode a+	| mode == stdFileMode = a+	| otherwise = bracket setup cleanup go+  where+	setup = setFileCreationMask nullFileMode+	cleanup = setFileCreationMask+	go _ = a+#else+noUmask _ a = a+#endif++combineModes :: [FileMode] -> FileMode+combineModes [] = undefined+combineModes [m] = m+combineModes (m:ms) = foldl unionFileModes m ms++isSticky :: FileMode -> Bool+#ifdef mingw32_HOST_OS+isSticky _ = False+#else+isSticky = checkMode stickyMode++stickyMode :: FileMode+stickyMode = 512++setSticky :: FilePath -> IO ()+setSticky f = modifyFileMode f $ addModes [stickyMode]+#endif++{- Writes a file, ensuring that its modes do not allow it to be read+ - by anyone other than the current user, before any content is written.+ -+ - On a filesystem that does not support file permissions, this is the same+ - as writeFile.+ -}+writeFileProtected :: FilePath -> String -> IO ()+writeFileProtected file content = do+	h <- openFile file WriteMode+	void $ tryIO $+		modifyFileMode file $+			removeModes [groupReadMode, otherReadMode]+	hPutStr h content+	hClose h

@@ -0,0 +1,93 @@+{- GHC File system encoding handling.+ -+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.FileSystemEncoding (+	fileEncoding,+	withFilePath,+	md5FilePath,+	decodeW8,+	encodeW8,+	truncateFilePath,+) where++import qualified GHC.Foreign as GHC+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++{- 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". -}+fileEncoding :: Handle -> IO ()+fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding++{- Marshal a Haskell FilePath into a NUL terminated C string using temporary+ - storage. The FilePath is encoded using the filesystem encoding,+ - reversing the decoding that should have been done when the FilePath+ - was obtained. -}+withFilePath :: FilePath -> (CString -> IO a) -> IO a+withFilePath fp f = Encoding.getFileSystemEncoding+	>>= \enc -> GHC.withCString enc fp f++{- Encodes a FilePath into a String, applying the filesystem encoding.+ -+ - There are very few things it makes sense to do with such an encoded+ - string. It's not a legal filename; it should not be displayed.+ - So this function is not exported, but instead used by the few functions+ - that can usefully consume it.+ -+ - This use of unsafePerformIO is belived to be safe; GHC's interface+ - only allows doing this conversion with CStrings, and the CString buffer+ - is allocated, used, and deallocated within the call, with no side+ - effects.+ -}+{-# NOINLINE _encodeFilePath #-}+_encodeFilePath :: FilePath -> String+_encodeFilePath fp = unsafePerformIO $ do+	enc <- Encoding.getFileSystemEncoding+	GHC.withCString enc fp $ GHC.peekCString Encoding.char8++{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}+md5FilePath :: FilePath -> MD5.Str+md5FilePath = MD5.Str . _encodeFilePath++{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.+ -+ - w82c 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.+ -}+{-# NOINLINE encodeW8 #-}+encodeW8 :: [Word8] -> FilePath+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++{- Truncates a FilePath to the given number of bytes (or less),+ - as represented on disk.+ -+ - Avoids returning an invalid part of a unicode byte sequence, at the+ - cost of efficiency when running on a large FilePath.+ -}+truncateFilePath :: Int -> FilePath -> FilePath+truncateFilePath n = go . reverse+  where+  	go f =+		let bytes = decodeW8 f+		in if length bytes <= n+			then reverse f+			else go (drop 1 f)

@@ -0,0 +1,178 @@+{- Formatted string handling.+ -+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Format (+	Format,+	gen,+	format,+	decode_c,+	encode_c,+	prop_idempotent_deencode+) where++import Text.Printf (printf)+import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord)+import Data.Maybe (fromMaybe)+import Data.Word (Word8)+import Data.List (isPrefixOf)+import qualified Codec.Binary.UTF8.String+import qualified Data.Map as M++import Utility.PartialPrelude++type FormatString = String++{- A format consists of a list of fragments. -}+type Format = [Frag]++{- A fragment is either a constant string,+ - or a variable, with a justification. -}+data Frag = Const String | Var String Justify+	deriving (Show)++data Justify = LeftJustified Int | RightJustified Int | UnJustified+	deriving (Show)++type Variables = M.Map String String++{- Expands a Format using some variables, generating a formatted string.+ - This can be repeatedly called, efficiently. -}+format :: Format -> Variables -> String+format f vars = concatMap expand f+  where+	expand (Const s) = s+	expand (Var name j)+		| "escaped_" `isPrefixOf` name =+			justify j $ encode_c_strict $+				getvar $ drop (length "escaped_") name+		| otherwise = justify j $ getvar name+	getvar name = fromMaybe "" $ M.lookup name vars+	justify UnJustified s        = s+	justify (LeftJustified i) s  = s ++ pad i s+	justify (RightJustified i) s = pad i s ++ s+	pad i s = take (i - length s) spaces+	spaces = repeat ' '++{- Generates a Format that can be used to expand variables in a+ - format string, such as "${foo} ${bar;10} ${baz;-10}\n"+ -+ - (This is the same type of format string used by dpkg-query.)+ -}+gen :: FormatString -> Format+gen = filter (not . empty) . fuse [] . scan [] . decode_c+  where+	-- The Format is built up in reverse, for efficiency,+	-- and can have many adjacent Consts. Fusing it fixes both+	-- problems.+	fuse f [] = f+	fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs+	fuse f (v:vs) = fuse (v:f) vs++	scan f (a:b:cs)+		| a == '$' && b == '{' = invar f [] cs+		| otherwise = scan (Const [a] : f ) (b:cs)+	scan f v = Const v : f++	invar f var [] = Const (novar var) : f+	invar f var (c:cs)+		| c == '}' = foundvar f var UnJustified cs+		| isAlphaNum c || c == '_' = invar f (c:var) cs+		| c == ';' = inpad "" f var cs+		| otherwise = scan ((Const $ novar $ c:var):f) cs++	inpad p f var (c:cs)+		| c == '}' = foundvar f var (readjustify $ reverse p) cs+		| otherwise = inpad (c:p) f var cs+	inpad p f var [] = Const (novar $ p++";"++var) : f+	readjustify = getjustify . fromMaybe 0 . readish+	getjustify i+		| i == 0 = UnJustified+		| i < 0 = LeftJustified (-1 * i)+		| otherwise = RightJustified i+	novar v = "${" ++ reverse v+	foundvar f v p = scan (Var (reverse v) p : f)++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.+ -}+decode_c :: FormatString -> FormatString+decode_c [] = []+decode_c s = unescape ("", s)+  where+	e = '\\'+	unescape (b, []) = b+	-- look for escapes starting with '\'+	unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)+	  where+		pair = span (/= e) v+	isescape x = x == e+	handle (x:'x':n1:n2:rest)+		| isescape x && allhex = (fromhex, rest)+	  where+	  	allhex = isHexDigit n1 && isHexDigit n2+		fromhex = [chr $ readhex [n1, n2]]+		readhex h = Prelude.read $ "0x" ++ h :: Int+	handle (x:n1:n2:n3:rest)+		| isescape x && alloctal = (fromoctal, rest)+	  where+		alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3+		fromoctal = [chr $ readoctal [n1, n2, n3]]+		readoctal o = Prelude.read $ "0o" ++ o :: Int+	-- \C is used for a few special characters+	handle (x:nc:rest)+		| isescape x = ([echar nc], rest)+	  where+		echar 'a' = '\a'+		echar 'b' = '\b'+		echar 'f' = '\f'+		echar 'n' = '\n'+		echar 'r' = '\r'+		echar 't' = '\t'+		echar 'v' = '\v'+		echar a = a+	handle n = ("", n)++{- Inverse of decode_c. -}+encode_c :: FormatString -> FormatString+encode_c = encode_c' (const False)++{- Encodes more strictly, including whitespace. -}+encode_c_strict :: FormatString -> FormatString+encode_c_strict = encode_c' isSpace++encode_c' :: (Char -> Bool) -> FormatString -> FormatString+encode_c' p = concatMap echar+  where+	e c = '\\' : [c]+	echar '\a' = e 'a'+	echar '\b' = e 'b'+	echar '\f' = e 'f'+	echar '\n' = e 'n'+	echar '\r' = e 'r'+	echar '\t' = e 't'+	echar '\v' = e 'v'+	echar '\\' = e '\\'+	echar '"'  = e '"'+	echar c+		| ord c < 0x20 = e_asc c -- low ascii+		| ord c >= 256 = e_utf c -- unicode+		| ord c > 0x7E = e_asc c -- high ascii+		| p c          = e_asc c -- unprintable ascii+		| otherwise    = [c]     -- printable ascii+	-- unicode character is decomposed to individual Word8s,+	-- and each is shown in octal+	e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])+	e_asc c = showoctal $ ord c+	showoctal i = '\\' : printf "%03o" i++{- for quickcheck -}+prop_idempotent_deencode :: String -> Bool+prop_idempotent_deencode s = s == decode_c (encode_c s)

@@ -0,0 +1,116 @@+{- Metered IO+ -+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE TypeSynonymInstances #-}++module Utility.Metered where++import Common++import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S+import System.IO.Unsafe+import Foreign.Storable (Storable(sizeOf))+import System.Posix.Types++{- An action that can be run repeatedly, updating it on the bytes processed.+ -+ - Note that each call receives the total number of bytes processed, so+ - far, *not* an incremental amount since the last call. -}+type MeterUpdate = (BytesProcessed -> IO ())++{- Total number of bytes processed so far. -}+newtype BytesProcessed = BytesProcessed Integer+	deriving (Eq, Ord)++class AsBytesProcessed a where+	toBytesProcessed :: a -> BytesProcessed+	fromBytesProcessed :: BytesProcessed -> a++instance AsBytesProcessed Integer where+	toBytesProcessed i = BytesProcessed i+	fromBytesProcessed (BytesProcessed i) = i++instance AsBytesProcessed Int where+	toBytesProcessed i = BytesProcessed $ toInteger i+	fromBytesProcessed (BytesProcessed i) = fromInteger i++instance AsBytesProcessed FileOffset where+	toBytesProcessed sz = BytesProcessed $ toInteger sz+	fromBytesProcessed (BytesProcessed sz) = fromInteger sz++addBytesProcessed :: AsBytesProcessed v => BytesProcessed -> v -> BytesProcessed+addBytesProcessed (BytesProcessed i) v = +	let (BytesProcessed n) = toBytesProcessed v+	in BytesProcessed $! i + n++zeroBytesProcessed :: BytesProcessed+zeroBytesProcessed = BytesProcessed 0++{- Sends the content of a file to an action, updating the meter as it's+ - consumed. -}+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 +  where+	go _ [] = return ()+	go sofar (c:cs) = do+		S.hPut h c+		let sofar' = addBytesProcessed sofar $ S.length c+		meterupdate sofar'+		go sofar' cs++meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()+meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h ->+	meteredWrite meterupdate h b++{- This is like L.hGetContents, but after each chunk is read, a meter+ - is updated based on the size of the chunk.+ -+ - 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.+ -+ - All the usual caveats about using unsafeInterleaveIO apply to the+ - meter updates, so use caution.+ -}+hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString+hGetContentsMetered h meterupdate = lazyRead zeroBytesProcessed+  where+	lazyRead sofar = unsafeInterleaveIO $ loop sofar++	loop sofar = do+		c <- S.hGetSome h defaultChunkSize+		if S.null c+			then do+				hClose h+				return $ L.empty+			else do+				let sofar' = addBytesProcessed sofar $+					S.length c+				meterupdate sofar'+				{- unsafeInterleaveIO causes this to be+				 - deferred until the data is read from the+				 - ByteString. -}+				cs <- lazyRead sofar'+				return $ L.append (L.fromChunks [c]) cs++{- Same default chunk size Lazy ByteStrings use. -}+defaultChunkSize :: Int+defaultChunkSize = 32 * k - chunkOverhead+  where+	k = 1024+	chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific

@@ -0,0 +1,138 @@+{- misc utility functions+ -+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Misc where++import System.IO+import Control.Monad+import Foreign+import Data.Char+import Data.List+import Control.Applicative+#ifndef mingw32_HOST_OS+import System.Posix.Process (getAnyProcessStatus)+import Utility.Exception+#endif++{- A version of hgetContents that is not lazy. Ensures file is + - all read before it gets closed. -}+hGetContentsStrict :: Handle -> IO String+hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s++{- A version of readFile that is not lazy. -}+readFileStrict :: FilePath -> IO String+readFileStrict = readFile >=> \s -> length s `seq` return s++{- Like break, but the item matching the condition is not included+ - in the second result list.+ -+ - separate (== ':') "foo:bar" = ("foo", "bar")+ - separate (== ':') "foobar" = ("foobar", "")+ -}+separate :: (a -> Bool) -> [a] -> ([a], [a])+separate c l = unbreak $ break c l+  where+	unbreak r@(a, b)+		| null b = r+		| otherwise = (a, tail b)++{- Breaks out the first line. -}+firstLine :: String -> String+firstLine = takeWhile (/= '\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. -}+segment :: (a -> Bool) -> [a] -> [[a]]+segment p l = map reverse $ go [] [] l+  where+	go c r [] = reverse $ c:r+	go c r (i:is)+		| p i = go [] (c:r) is+		| otherwise = go (i:c) r is++prop_segment_regressionTest :: Bool+prop_segment_regressionTest = all id+	-- Even an empty list is a segment.+	[ segment (== "--") [] == [[]]+	-- There are two segements in this list, even though the first is empty.+	, segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]]+	]++{- Includes the delimiters as segments of their own. -}+segmentDelim :: (a -> Bool) -> [a] -> [[a]]+segmentDelim p l = map reverse $ go [] [] l+  where+	go c r [] = reverse $ c:r+	go c r (i:is)+		| p i = go [] ([i]:c:r) is+		| otherwise = go (i:c) r is++{- Replaces multiple values in a string.+ -+ - Takes care to skip over just-replaced values, so that they are not+ - mangled. For example, massReplace [("foo", "new foo")] does not+ - replace the "new foo" with "new new foo".+ -}+massReplace :: [(String, String)] -> String -> String+massReplace vs = go [] vs+  where++	go acc _ [] = concat $ reverse acc+	go acc [] (c:cs) = go ([c]:acc) vs cs+	go acc ((val, replacement):rest) s+		| val `isPrefixOf` s =+			go (replacement:acc) vs (drop (length val) s)+		| otherwise = go acc rest s++{- Given two orderings, returns the second if the first is EQ and returns+ - the first otherwise.+ -+ - Example use:+ -+ - compare lname1 lname2 `thenOrd` compare fname1 fname2+ -}+thenOrd :: Ordering -> Ordering -> Ordering+thenOrd EQ x = x+thenOrd x _ = x+{-# INLINE thenOrd #-}++{- Wrapper around hGetBufSome that returns a String.+ -+ - The null string is returned on eof, otherwise returns whatever+ - data is currently available to read from the handle, or waits for+ - data to be written to it if none is currently available.+ - + - Note on encodings: The normal encoding of the Handle is ignored;+ - each byte is converted to a Char. Not unicode clean!+ -}+hGetSomeString :: Handle -> Int -> IO String+hGetSomeString h sz = do+	fp <- mallocForeignPtrBytes sz+	len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz+	map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)+  where+	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 = do+	-- throws an exception when there are no child processes+	catchDefaultIO Nothing (getAnyProcessStatus False True)+		>>= maybe (return ()) (const reapZombies)++#else+reapZombies = return ()+#endif

@@ -0,0 +1,69 @@+{- monadic stuff+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Monad where++import Data.Maybe+import Control.Monad++{- Return the first value from a list, if any, satisfying the given+ - predicate -}+firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)+firstM _ [] = return Nothing+firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)++{- Runs the action on values from the list until it succeeds, returning+ - its result. -}+getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+getM _ [] = return Nothing+getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x++{- Returns true if any value in the list satisfies the predicate,+ - stopping once one is found. -}+anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool+anyM p = liftM isJust . firstM p++allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+allM _ [] = return True+allM p (x:xs) = p x <&&> allM p xs++{- Runs an action on values from a list until it succeeds. -}+untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool+untilTrue = flip anyM++{- if with a monadic conditional. -}+ifM :: Monad m => m Bool -> (m a, m a) -> m a+ifM cond (thenclause, elseclause) = do+	c <- cond+	if c then thenclause else elseclause++{- short-circuiting monadic || -}+(<||>) :: Monad m => m Bool -> m Bool -> m Bool+ma <||> mb = ifM ma ( return True , mb )++{- short-circuiting monadic && -}+(<&&>) :: Monad m => m Bool -> m Bool -> m Bool+ma <&&> mb = ifM ma ( mb , return False )++{- Same fixity as && and || -}+infixr 3 <&&>+infixr 2 <||>++{- Runs an action, passing its value to an observer before returning it. -}+observe :: Monad m => (a -> m b) -> m a -> m a+observe observer a = do+	r <- a+	_ <- observer r+	return r++{- b `after` a runs first a, then b, and returns the value of a -}+after :: Monad m => m b -> m a -> m a+after = observe . const++{- do nothing -}+noop :: Monad m => m ()+noop = return ()

@@ -0,0 +1,68 @@+{- Parts of the Prelude are partial functions, which are a common source of+ - bugs.+ -+ - This exports functions that conflict with the prelude, which avoids+ - them being accidentially used.+ -}++module Utility.PartialPrelude where++import qualified Data.Maybe++{- read should be avoided, as it throws an error+ - Instead, use: readish -}+read :: Read a => String -> a+read = Prelude.read++{- head is a partial function; head [] is an error+ - Instead, use: take 1 or headMaybe -}+head :: [a] -> a+head = Prelude.head++{- tail is also partial+ - Instead, use: drop 1 -}+tail :: [a] -> [a]+tail = Prelude.tail++{- init too+ - Instead, use: beginning -}+init :: [a] -> [a]+init = Prelude.init++{- last too+ - Instead, use: end or lastMaybe -}+last :: [a] -> a+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.+ -}+readish :: Read a => String -> Maybe a+readish s = case reads s of+	((x,_):_) -> Just x+	_ -> Nothing++{- Like head but Nothing on empty list. -}+headMaybe :: [a] -> Maybe a+headMaybe = Data.Maybe.listToMaybe++{- Like last but Nothing on empty list. -}+lastMaybe :: [a] -> Maybe a+lastMaybe [] = Nothing+lastMaybe v = Just $ Prelude.last v++{- All but the last element of a list.+ - (Like init, but no error on an empty list.) -}+beginning :: [a] -> [a]+beginning [] = []+beginning l = Prelude.init l++{- Like last, but no error on an empty list. -}+end :: [a] -> [a]+end [] = []+end l = [Prelude.last l]

@@ -0,0 +1,254 @@+{- path manipulation+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE PackageImports, CPP #-}++module Utility.Path where++import Data.String.Utils+import System.FilePath+import System.Directory+import Data.List+import Data.Maybe+import Data.Char+import Control.Applicative++#ifdef mingw32_HOST_OS+import Data.Char+import qualified System.FilePath.Posix as Posix+#else+import qualified "MissingH" System.Path as MissingH+import System.Posix.Files+#endif++import Utility.Monad+import Utility.UserInfo++{- Makes a path absolute if it's not already.+ - The first parameter is a base directory (ie, the cwd) to use if the path+ - is not already absolute.+ -+ - On Unix, collapses and normalizes ".." etc in the path. May return Nothing+ - if the path cannot be normalized.+ -+ - MissingH's absNormPath does not work on Windows, so on Windows+ - no normalization is done.+ -}+absNormPath :: FilePath -> FilePath -> Maybe FilePath+#ifndef mingw32_HOST_OS+absNormPath dir path = MissingH.absNormPath dir path+#else+absNormPath dir path = Just $ combine dir path+#endif++{- Returns the parent directory of a path.+ -+ - To allow this to be easily used in loops, which terminate upon reaching the+ - top, the parent of / is "" -}+parentDir :: FilePath -> FilePath+parentDir dir+	| null dirs = ""+	| otherwise = joinDrive drive (join s $ init dirs)+  where+	-- 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]++prop_parentDir_basics :: FilePath -> Bool+prop_parentDir_basics dir+	| null dir = True+	| dir == "/" = parentDir dir == ""+	| otherwise = p /= dir+  where+	p = parentDir dir++{- Checks if the first FilePath is, or could be said to contain the second.+ - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc+ - are all equivilant.+ -}+dirContains :: FilePath -> FilePath -> Bool+dirContains a b = a == b || a' == b' || (a'++[pathSeparator]) `isPrefixOf` b'+  where+	norm p = fromMaybe "" $ absNormPath p "."+	a' = norm a+	b' = norm b++{- Converts a filename into a normalized, absolute path.+ -+ - Unlike Directory.canonicalizePath, this does not require the path+ - already exists. -}+absPath :: FilePath -> IO FilePath+absPath file = do+	cwd <- getCurrentDirectory+	return $ absPathFrom cwd file++{- Converts a filename into a normalized, absolute path+ - from the specified cwd. -}+absPathFrom :: FilePath -> FilePath -> FilePath+absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file+  where+	bad = error $ "unable to normalize " ++ file++{- Constructs a relative path from the CWD to a file.+ -+ - For example, assuming CWD is /tmp/foo/bar:+ -    relPathCwdToFile "/tmp/foo" == ".."+ -    relPathCwdToFile "/tmp/foo/bar" == "" + -}+relPathCwdToFile :: FilePath -> IO FilePath+relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f++{- Constructs a relative path from a directory to a file.+ -+ - Both must be absolute, and normalized (eg with absNormpath).+ -}+relPathDirToFile :: FilePath -> FilePath -> FilePath+relPathDirToFile from to = join s $ dotdots ++ uncommon+  where+	s = [pathSeparator]+	pfrom = split s from+	pto = split s to+	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++prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool+prop_relPathDirToFile_basics from to+	| from == to = null r+	| otherwise = not (null r)+  where+	r = relPathDirToFile from to ++prop_relPathDirToFile_regressionTest :: Bool+prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference+  where+	{- Two paths have the same directory component at the same+	 - location, but it's not really the same directory.+	 - Code used to get this wrong. -}+	same_dir_shortcurcuits_at_difference =+		relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])+			(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])+				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]++{- Given an original list of paths, and an expanded list derived from it,+ - generates a list of lists, where each sublist corresponds to one of the+ - original paths. When the original path is a directory, any items+ - in the expanded list that are contained in that directory will appear in+ - its segment.+ -}+segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]+segmentPaths [] new = [new]+segmentPaths [_] new = [new] -- optimisation+segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest+  where+	(found, rest)=partition (l `dirContains`) new++{- 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 a paths = segmentPaths paths <$> a paths++{- Converts paths in the home directory to use ~/ -}+relHome :: FilePath -> IO String+relHome path = do+	home <- myHomeDir+	return $ if dirContains home path+		then "~/" ++ relPathDirToFile home path+		else path++{- Checks if a command is available in PATH.+ -+ - The command may be fully-qualified, in which case, this succeeds as+ - long as it exists. -}+inPath :: String -> IO Bool+inPath command = isJust <$> searchPath command++{- Finds a command in PATH and returns the full path to it.+ -+ - The command may be fully qualified already, in which case it will+ - be returned if it exists.+ -}+searchPath :: String -> IO (Maybe FilePath)+searchPath command+	| isAbsolute command = check command+	| otherwise = getSearchPath >>= getM indir+  where+	indir d = check $ d </> command+	check f = firstM doesFileExist+#ifdef mingw32_HOST_OS+		[f, f ++ ".exe"]+#else+		[f]+#endif++{- Checks if a filename is a unix dotfile. All files inside dotdirs+ - count as dotfiles. -}+dotfile :: FilePath -> Bool+dotfile file+	| f == "." = False+	| f == ".." = False+	| f == "" = False+	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory 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+	l <- fromIntegral <$> getPathVar dir FileNameLimit+	if l <= 0+		then return 255+		else return $ minimum [l, 255]+  where+#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.+ -+ - All spaces and punctuation are replaced with '_', except for '.'+ - "../" will thus turn into ".._", which is safe.+ -}+sanitizeFilePath :: String -> FilePath+sanitizeFilePath = map sanitize+  where+  	sanitize c+		| c == '.' = c+		| isSpace c || isPunctuation c || c == '/' = '_'+		| otherwise = c

@@ -0,0 +1,356 @@+{- System.Process enhancements, including additional ways of running+ - processes, and logging.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP, Rank2Types #-}++module Utility.Process (+	module X,+	CreateProcess,+	StdHandle(..),+	readProcess,+	readProcessEnv,+	writeReadProcessEnv,+	forceSuccessProcess,+	checkSuccessProcess,+	ignoreFailureProcess,+	createProcessSuccess,+	createProcessChecked,+	createBackgroundProcess,+	processTranscript,+	withHandle,+	withBothHandles,+	withQuietOutput,+	withNullHandle,+	createProcess,+	startInteractiveProcess,+	stdinHandle,+	stdoutHandle,+	stderrHandle,+) where++import qualified System.Process+import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)+import System.Process hiding (createProcess, readProcess)+import System.Exit+import System.IO+import System.Log.Logger+import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad+#ifndef mingw32_HOST_OS+import System.Posix.IO+#else+import Control.Applicative+#endif+import Data.Maybe++import Utility.Misc+import Utility.Exception++type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a++data StdHandle = StdinHandle | StdoutHandle | StderrHandle+	deriving (Eq)++{- Normally, when reading from a process, it does not need to be fed any+ - standard input. -}+readProcess :: FilePath	-> [String] -> IO String+readProcess cmd args = readProcessEnv cmd args Nothing++readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String+readProcessEnv cmd args environ =+	withHandle StdoutHandle createProcessSuccess p $ \h -> do+		output  <- hGetContentsStrict h+		hClose h+		return output+  where+	p = (proc cmd args)+		{ std_out = CreatePipe+		, env = environ+		}++{- Runs an action to write to a process on its stdin, + - returns its output, and also allows specifying the environment.+ -}+writeReadProcessEnv+	:: FilePath+	-> [String]+	-> Maybe [(String, String)]+	-> (Maybe (Handle -> IO ()))+	-> (Maybe (Handle -> IO ()))+	-> IO String+writeReadProcessEnv cmd args environ writestdin adjusthandle = do+	(Just inh, Just outh, _, pid) <- createProcess p++	maybe (return ()) (\a -> a inh) adjusthandle+	maybe (return ()) (\a -> a outh) adjusthandle++	-- fork off a thread to start consuming the output+	output  <- hGetContents outh+	outMVar <- newEmptyMVar+	_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()++	-- now write and flush any input+	maybe (return ()) (\a -> a inh >> hFlush inh) writestdin+	hClose inh -- done with stdin++	-- wait on the output+	takeMVar outMVar+	hClose outh++	-- wait on the process+	forceSuccessProcess p pid++	return output++  where+	p = (proc cmd args)+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		, env = environ+		}++{- 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++{- Waits for a ProcessHandle and returns True if it exited successfully.+ - Note that using this with createProcessChecked will throw away+ - the Bool, and is only useful to ignore the exit code of a process,+ - while still waiting for it. -}+checkSuccessProcess :: ProcessHandle -> IO Bool+checkSuccessProcess pid = do+	code <- waitForProcess pid+	return $ code == ExitSuccess++ignoreFailureProcess :: ProcessHandle -> IO Bool+ignoreFailureProcess pid = do+	void $ waitForProcess pid+	return True++{- Runs createProcess, then an action on its handles, and then+ - forceSuccessProcess. -}+createProcessSuccess :: CreateProcessRunner+createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a++{- Runs createProcess, then an action on its handles, and then+ - a checker action on its exit code, which must wait for the process. -}+createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner+createProcessChecked checker p a = do+	t@(_, _, _, pid) <- createProcess p+	r <- tryNonAsync $ a t+	_ <- checker pid+	either E.throw return r++{- Leaves the process running, suitable for lazy streaming.+ - Note: Zombies will result, and must be waited on. -}+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)+#ifndef mingw32_HOST_OS+{- This implementation interleves stdout and stderr in exactly the order+ - the process writes them. -}+processTranscript cmd opts input = do+	(readf, writef) <- createPipe+	readh <- fdToHandle readf+	writeh <- fdToHandle writef+	p@(_, _, _, pid) <- createProcess $+		(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++	-- now write and flush any input+	case input of+		Just s -> do+			let inh = stdinHandle p+			unless (null s) $ do+				hPutStr inh s+				hFlush inh+			hClose inh+		Nothing -> return ()++	transcript <- get++	ok <- checkSuccessProcess pid+	return (transcript, ok)+#else+{- This implementation for Windows puts stderr after stdout. -}+processTranscript cmd opts input = do+	p@(_, _, _, pid) <- createProcess $+		(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)++	case input of+		Just s -> do+			let inh = stdinHandle p+			unless (null s) $ do+				hPutStr inh s+				hFlush inh+			hClose inh+		Nothing -> return ()+	+	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++{- 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. -}+withHandle+	:: StdHandle+	-> CreateProcessRunner+	-> CreateProcess+	-> (Handle -> IO a)+	-> IO a+withHandle h creator p a = creator p' $ a . select+  where+	base = p+		{ std_in = Inherit+		, 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 })++{- Like withHandle, but passes (stdin, stdout) handles to the action. -}+withBothHandles+	:: CreateProcessRunner+	-> CreateProcess+	-> ((Handle, Handle) -> IO a)+	-> IO a+withBothHandles creator p a = creator p' $ a . bothHandles+  where+	p' = p+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		}++{- Forces the CreateProcessRunner to run quietly;+ - both stdout and stderr are discarded. -}+withQuietOutput+	:: CreateProcessRunner+	-> CreateProcess+	-> IO ()+withQuietOutput creator p = withNullHandle $ \nullh -> do+	let p' = p+		{ std_out = UseHandle nullh+		, std_err = UseHandle nullh+		}+	creator p' $ const $ return ()++withNullHandle :: (Handle -> IO a) -> IO a+withNullHandle = withFile devnull WriteMode+  where+#ifndef mingw32_HOST_OS+	devnull = "/dev/null"+#else+	devnull = "NUL"+#endif++{- Extract a desired handle from createProcess's tuple.+ - These partial functions are safe as long as createProcess is run+ - with appropriate parameters to set up the desired handle.+ - Get it wrong and the runtime crash will always happen, so should be+ - easily noticed. -}+type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle+stdinHandle :: HandleExtractor+stdinHandle (Just h, _, _, _) = h+stdinHandle _ = error "expected stdinHandle"+stdoutHandle :: HandleExtractor+stdoutHandle (_, Just h, _, _) = h+stdoutHandle _ = error "expected stdoutHandle"+stderrHandle :: HandleExtractor+stderrHandle (_, _, Just h, _) = h+stderrHandle _ = error "expected stderrHandle"+bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)+bothHandles (Just hin, Just hout, _, _) = (hin, hout)+bothHandles _ = error "expected bothHandles"++{- Debugging trace for a CreateProcess. -}+debugProcess :: CreateProcess -> IO ()+debugProcess p = do+	debugM "Utility.Process" $ unwords+		[ action ++ ":"+		, showCmd p+		]+  where+	action+		| piped (std_in p) && piped (std_out p) = "chat"+		| piped (std_in p)                      = "feed"+		| piped (std_out p)                     = "read"+		| otherwise                             = "call"+	piped Inherit = False+	piped _ = True++{- Shows the command that a CreateProcess will run. -}+showCmd :: CreateProcess -> String+showCmd = go . cmdspec+  where+	go (ShellCommand s) = s+	go (RawCommand c ps) = c ++ " " ++ show ps++{- Starts an interactive process. Unlike runInteractiveProcess in+ - System.Process, stderr is inherited. -}+startInteractiveProcess+	:: FilePath+	-> [String]+	-> Maybe [(String, String)]+	-> IO (ProcessHandle, Handle, Handle)+startInteractiveProcess cmd args environ = do+	let p = (proc cmd args)+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		, env = environ+		}+	(Just from, Just to, _, pid) <- createProcess p+	return (pid, to, from)++{- Wrapper around System.Process function that does debug logging. -}+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess p = do+	debugProcess p+	System.Process.createProcess p

@@ -0,0 +1,152 @@+{- various rsync stuff+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Rsync where++import Common+import Utility.Metered++import Data.Char+import System.Console.GetOpt+import Data.Tuple.Utils++{- Generates parameters to make rsync use a specified command as its remote+ - shell. -}+rsyncShell :: [CommandParam] -> [CommandParam]+rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)]+  where+	{- 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) ++ "'"++{- Runs rsync in server mode to send a file. -}+rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool+rsyncServerSend options file = rsync $+	rsyncServerParams ++ Param "--sender" : options ++ [File file]++{- Runs rsync in server mode to receive a file. -}+rsyncServerReceive :: [CommandParam] -> FilePath -> IO Bool+rsyncServerReceive options file = rsync $+	rsyncServerParams ++ options ++ [File file]++rsyncServerParams :: [CommandParam]+rsyncServerParams =+	[ Param "--server"+	-- preserve timestamps+	, Param "-t"+	-- allow resuming of transfers of big files+	, Param "--inplace"+	-- other options rsync normally uses in server mode+	, Params "-e.Lsf ."+	]++rsyncUseDestinationPermissions :: CommandParam+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+ - paths to files. (It thinks that C:foo refers to a host named "C").+ - Fix up all Files in the Params appropriately. -}+rsyncParamsFixup :: [CommandParam] -> [CommandParam]+rsyncParamsFixup = map fixup+  where+  	fixup (File f) = File (toCygPath f)+	fixup p = p++{- Runs rsync, but intercepts its progress output and updates a meter.+ - The progress output is also output to stdout. + -+ - The params must enable rsync's --progress mode for this to work.+ -}+rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool+rsyncProgress meterupdate params = do+	r <- withHandle StdoutHandle createProcessSuccess p (feedprogress 0 [])+	{- For an unknown reason, piping rsync's output like this does+	 - causes it to run a second ssh process, which it neglects to wait+	 - on. Reap the resulting zombie. -}+	reapZombies+	return r+  where+	p = proc "rsync" (toCommand $ rsyncParamsFixup params)+	feedprogress prev buf h = do+		s <- hGetSomeString h 80+		if null s+			then return True+			else do+				putStr s+				hFlush stdout+				let (mbytes, buf') = parseRsyncProgress (buf++s)+				case mbytes of+					Nothing -> feedprogress prev buf' h+					(Just bytes) -> do+						when (bytes /= prev) $+							meterupdate $ toBytesProcessed bytes+						feedprogress bytes buf' h++{- Checks if an rsync url involves the remote shell (ssh or rsh).+ - Use of such urls with rsync requires additional shell+ - escaping. -}+rsyncUrlIsShell :: String -> Bool+rsyncUrlIsShell s+	| "rsync://" `isPrefixOf` s = False+	| otherwise = go s+  where+	-- host::dir is rsync protocol, while host:dir is ssh/rsh+	go [] = False+	go (c:cs)+		| c == '/' = False -- got to directory with no colon+		| c == ':' = not $ ":" `isPrefixOf` cs+		| otherwise = go cs++{- Checks if a rsync url is really just a local path. -}+rsyncUrlIsPath :: String -> Bool+rsyncUrlIsPath s+	| rsyncUrlIsShell s = False+	| otherwise = ':' `notElem` s++{- Parses the String looking for rsync progress output, and returns+ - Maybe the number of bytes rsynced so far, and any any remainder of the+ - string that could be an incomplete progress output. That remainder+ - should be prepended to future output, and fed back in. This interface+ - allows the output to be read in any desired size chunk, or even one+ - character at a time.+ -+ - Strategy: Look for chunks prefixed with \r (rsync writes a \r before+ - the first progress output, and each thereafter). The first number+ - after the \r is the number of bytes processed. After the number,+ - there must appear some whitespace, or we didn't get the whole number,+ - and return the \r and part we did get, for later processing.+ -}+parseRsyncProgress :: String -> (Maybe Integer, String)+parseRsyncProgress = go [] . reverse . progresschunks+  where+	go remainder [] = (Nothing, remainder)+	go remainder (x:xs) = case parsebytes (findbytesstart x) of+		Nothing -> go (delim:x++remainder) xs+		Just b -> (Just b, remainder)++	delim = '\r'+	{- 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]+	findbytesstart s = dropWhile isSpace s+	parsebytes s = case break isSpace s of+		([], _) -> Nothing+		(_, []) -> Nothing+		(b, _) -> readish b++{- Filters options to those that are safe to pass to rsync in server mode,+ - without causing it to eg, expose files. -}+filterRsyncSafeOptions :: [String] -> [String]+filterRsyncSafeOptions = fst3 . getOpt Permute+	[ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ]+  where+	reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) ""

@@ -0,0 +1,120 @@+{- safely running shell commands+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.SafeCommand where++import System.Exit+import Utility.Process+import System.Process (env)+import Data.String.Utils+import Control.Applicative+import System.FilePath+import Data.Char++{- A type for parameters passed to a shell command. A command can+ - be passed either some Params (multiple parameters can be included,+ - whitespace-separated, or a single Param (for when parameters contain+ - whitespace), or a File.+ -}+data CommandParam = Params String | Param String | File FilePath+	deriving (Eq, Show, Ord)++{- Used to pass a list of CommandParams to a function that runs+ - a command and expects Strings. -}+toCommand :: [CommandParam] -> [String]+toCommand = concatMap unwrap+  where+	unwrap (Param s) = [s]+	unwrap (Params s) = filter (not . null) (split " " 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:"./"++{- Run a system command, and returns True or False+ - if it succeeded or failed.+ -}+boolSystem :: FilePath -> [CommandParam] -> IO Bool+boolSystem command params = boolSystemEnv command params Nothing++boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool+boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ+  where+	dispatch ExitSuccess = True+	dispatch _ = False++{- Runs a system command, returning the exit status. -}+safeSystem :: FilePath -> [CommandParam] -> IO ExitCode+safeSystem command params = safeSystemEnv command params Nothing++safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode+safeSystemEnv command params environ = do+	(_, _, _, pid) <- createProcess (proc command $ toCommand params)+		{ env = environ }+	waitForProcess pid++{- Wraps a shell command line inside sh -c, allowing it to be run in a+ - login shell that may not support POSIX shell, eg csh. -}+shellWrap :: String -> String+shellWrap cmdline = "sh -c " ++ shellEscape cmdline++{- Escapes a filename or other parameter to be safely able to be exposed to+ - the shell.+ -+ - This method works for POSIX shells, as well as other shells like csh.+ -}+shellEscape :: String -> String+shellEscape f = "'" ++ escaped ++ "'"+  where+	-- replace ' with '"'"'+	escaped = join "'\"'\"'" $ split "'" f++{- Unescapes a set of shellEscaped words or filenames. -}+shellUnEscape :: String -> [String]+shellUnEscape [] = []+shellUnEscape s = word : shellUnEscape rest+  where+	(word, rest) = findword "" s+	findword w [] = (w, "")+	findword w (c:cs)+		| c == ' ' = (w, cs)+		| c == '\'' = inquote c w cs+		| c == '"' = inquote c w cs+		| otherwise = findword (w++[c]) cs+	inquote _ w [] = (w, "")+	inquote q w (c:cs)+		| c == q = findword w cs+		| otherwise = inquote q (w++[c]) cs++{- For quickcheck. -}+prop_idempotent_shellEscape :: String -> Bool+prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s+prop_idempotent_shellEscape_multiword :: [String] -> Bool+prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s++{- Segements a list of filenames into groups that are all below the manximum+ - command-line length limit. Does not preserve order. -}+segmentXargs :: [FilePath] -> [[FilePath]]+segmentXargs l = go l [] 0 []+  where+	go [] c _ r = c:r+	go (f:fs) c accumlen r+		| len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)+		| otherwise = go fs (f:c) newlen r+	  where+		len = length f+		newlen = accumlen + len++	{- 10k of filenames per command, well under Linux's 20k limit;+	 - allows room for other parameters etc. -}+	maxlen = 10240

@@ -0,0 +1,88 @@+{- Temporary files and directories.+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Tmp where++import Control.Exception (bracket)+import System.IO+import System.Directory+import Control.Monad.IfElse++import Utility.Exception+import System.FilePath+import Utility.FileSystemEncoding++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 :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()+viaTmp a file content = do+	let (dir, base) = splitFileName file+	createDirectoryIfMissing True dir+	(tmpfile, handle) <- openTempFile dir (base ++ ".tmp")+	hClose handle+	a tmpfile content+	renameFile tmpfile file++{- Runs an action with a tmp file located in the system's tmp directory+ - (or in "." if there is none) then removes the file. -}+withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a+withTmpFile template a = do+	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	withTmpFileIn tmpdir template a++{- Runs an action with a tmp file located in the specified directory,+ - then removes the file. -}+withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a+withTmpFileIn tmpdir template a = bracket create remove use+  where+	create = openTempFile tmpdir template+	remove (name, handle) = do+		hClose handle+		catchBoolIO (removeFile name >> return True)+	use (name, handle) = a name handle++{- 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 :: Template -> (FilePath -> IO a) -> IO a+withTmpDir template a = do+	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	withTmpDirIn tmpdir template a++{- Runs an action with a tmp directory located within a specified directory,+ - then removes the tmp directory and all its contents. -}+withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a+withTmpDirIn tmpdir template = bracket create remove+  where+	remove d = whenM (doesDirectoryExist d) $+		removeDirectoryRecursive d+	create = do+		createDirectoryIfMissing True tmpdir+		makenewdir (tmpdir </> template) (0 :: Int)+	makenewdir t n = do+		let dir = t ++ "." ++ show n+		either (const $ makenewdir t $ n + 1) (const $ return dir)+			=<< tryIO (createDirectory dir)++{- 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.+ -+ - This generates a template that is never too long.+ - (Well, it allocates 20 characters for use in making a unique temp file,+ - anyway, which is enough for the current implementation and any+ - likely implementation.)+ -}+relatedTemplate :: FilePath -> FilePath+relatedTemplate f+	| len > 20 = truncateFilePath (len - 20) f+	| otherwise = f+  where+	len = length f

@@ -0,0 +1,55 @@+{- user info+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.UserInfo (+	myHomeDir,+	myUserName,+	myUserGecos,+) where++import Control.Applicative+import System.PosixCompat++import Utility.Env++{- Current user's home directory.+ -+ - getpwent will fail on LDAP or NIS, so use HOME if set. -}+myHomeDir :: IO FilePath+myHomeDir = myVal env homeDirectory+  where+#ifndef mingw32_HOST_OS+	env = ["HOME"]+#else+	env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin+#endif++{- Current user's user name. -}+myUserName :: IO String+myUserName = myVal env userName+  where+#ifndef mingw32_HOST_OS+	env = ["USER", "LOGNAME"]+#else+	env = ["USERNAME", "USER", "LOGNAME"]+#endif++myUserGecos :: IO String+#ifdef __ANDROID__+myUserGecos = return "" -- userGecos crashes on Android+#else+myUserGecos = myVal [] userGecos+#endif++myVal :: [String] -> (UserEntry -> String) -> IO String+myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars+  where+	check [] = return Nothing+	check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v+	getpwent = getUserEntryForID =<< getEffectiveUserID

@@ -0,0 +1,6 @@+{- configure program -}++import Build.Configure++main :: IO ()+main = run tests

@@ -0,0 +1,46 @@+`git-repair` can repair various forms of damage to git repositories.++It is a complement to `git fsck`, which finds problems, but does not fix+them.++## download++	git clone git://git-repair.branchable.com/ git-repair++## install++This is a Haskell program, developed as a spinoff of+[git-annex](http://git-annex.branchable.com/).++To build it, you will need to install the+[Haskell Platform](http://www.haskell.org/platform/).++Then to install it:++	cabal update; cabal install git-repair --bindir=$HOME/bin++## how it works++`git-repair` starts by deleting all corrupt objects, and+retreiving all missing objects that it can from the remotes of the+repository.++If that is not sufficient to fully recover the repository, it can also+reset branches back to commits before the corruption happened, delete+branches that are no longer available due to the lost data, and remove any+missing files from the index. It will only do this if run with the+`--force` option, since that rewrites history and throws out missing data.++After running this command, you will probably want to run `git fsck` to+verify it fixed the repository.++Note that fsck may still complain about objects referenced by the reflog,+or the stash, if they were unable to be recovered. This command does not+try to clean up either the reflog or the stash. ++Also note that the `--force` option never touches tags, even if they are no+longer usable due to missing data, so fack may also find problems with+tags.++Since this command unpacks all packs in the repository, you may want to+run `git gc` afterwards.

@@ -0,0 +1,37 @@+.TH  +.SH NAME+git\-repair \- Fix a broken git repository+.PP+.SH SYNOPSIS+git\-repair [\-\-force]+.PP+.SH DESCRIPTION+This can fix a corrupt or broken git repository, which git fsck would+only complain has problems.+.PP+It does by deleting all corrupt objects, and retreiving all missing+objects that it can from the remotes of the repository.+.PP+If that is not sufficient to fully recover the repository, it can also+reset branches back to commits before the corruption happened, delete+branches that are no longer available due to the lost data, and remove any+missing files from the index. It will only do this if run with the+\fB\-\-force\fP option, since that rewrites history and throws out missing data.+Note that the \fB\-\-force\fP option never touches tags, even if they are no+longer usable due to missing data.+.PP+After running this command, you will probably want to run \fBgit fsck\fP to+verify it fixed the repository. Note that fsck may still complain about+objects referenced by the reflog, or the stash, if they were unable to be+recovered. This command does not try to clean up either the reflog or the+stash.+.PP+Since this command unpacks all packs in the repository, you may want to+run \fBgit gc\fP afterwards.+.PP+.SH AUTHOR+Joey Hess <joey@kitenet.net>+.PP+<http://git\-repair.branchable.com/>+.PP+.PP

@@ -0,0 +1,30 @@+Name: git-repair+Version: 1.20131118+Cabal-Version: >= 1.6+License: GPL+Maintainer: Joey Hess <joey@kitenet.net>+Author: Joey Hess+Stability: Stable+Copyright: 2013 Joey Hess+License-File: GPL+Build-Type: Custom+Homepage: http://git-reair.branchable.com/+Category: Utility+Synopsis: repairs a damanged git repisitory+Description:+ git-repair can repair various forms of damage to git repositories.++Executable git-repair+  Main-Is: git-repair.hs+  GHC-Options: -Wall+  Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,+   network, extensible-exceptions, unix-compat, bytestring,+   base >= 4.5, base < 5, IfElse, pretty-show, text, process,+   utf8-string, async++  if (! os(windows))+    Build-Depends: unix++source-repository head+  type: git+  location: git://git-repair.branchable.com/

@@ -0,0 +1,38 @@+{- git-repair program+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++import System.Environment+import Data.Tuple.Utils++import Common+import qualified Git.CurrentRepo+import qualified Git.Repair+import qualified Git.Config++header :: String+header = "Usage: git-repair"++usage :: a+usage = error $ "bad parameters\n\n" ++ header++parseArgs :: IO Bool+parseArgs = do+	args <- getArgs+	return $ or $ map parse args+  where+	parse "--force" = True+	parse _ = usage++main :: IO ()+main = do+	forced <- parseArgs+	+	g <- Git.Config.read =<< Git.CurrentRepo.get+	ifM (fst3 <$> Git.Repair.runRepair forced g)+		( exitSuccess+		, exitFailure+		)