summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess <joeyh@debian.org>2013-12-03 15:02:21 -0400
committerJoey Hess <joeyh@debian.org>2013-12-03 15:02:21 -0400
commita4f3e112954e1b785c84c339bcbd83597a89335e (patch)
treeeb2a975663782f83e6b20d6d239447d7222de81b
downloadgit-repair-a4f3e112954e1b785c84c339bcbd83597a89335e.tar.gz
git-repair (1.20131203) unstable; urgency=low
* Fix build deps. Closes: #731179 # imported from the archive
-rw-r--r--Build/Configure.hs30
-rw-r--r--Build/TestConfig.hs143
-rw-r--r--Build/Version.hs69
-rwxr-xr-xBuild/make-sdist.sh21
-rw-r--r--Common.hs35
-rw-r--r--GPL674
-rw-r--r--Git.hs140
-rw-r--r--Git/Branch.hs153
-rw-r--r--Git/BuildVersion.hs21
-rw-r--r--Git/CatFile.hs108
-rw-r--r--Git/Command.hs138
-rw-r--r--Git/Config.hs198
-rw-r--r--Git/Construct.hs236
-rw-r--r--Git/CurrentRepo.hs67
-rw-r--r--Git/Destroyer.hs126
-rw-r--r--Git/FilePath.hs64
-rw-r--r--Git/Filename.hs28
-rw-r--r--Git/Fsck.hs81
-rw-r--r--Git/Index.hs32
-rw-r--r--Git/LsFiles.hs214
-rw-r--r--Git/LsTree.hs65
-rw-r--r--Git/Objects.hs35
-rw-r--r--Git/Ref.hs139
-rw-r--r--Git/RefLog.hs22
-rw-r--r--Git/Remote.hs115
-rw-r--r--Git/Repair.hs548
-rw-r--r--Git/Sha.hs39
-rw-r--r--Git/Types.hs95
-rw-r--r--Git/UpdateIndex.hs86
-rw-r--r--Git/Url.hs71
-rw-r--r--Git/Version.hs43
-rw-r--r--Makefile34
-rw-r--r--Setup.hs14
-rw-r--r--Utility/Applicative.hs16
-rw-r--r--Utility/Batch.hs93
-rw-r--r--Utility/CoProcess.hs93
-rw-r--r--Utility/Data.hs17
-rw-r--r--Utility/Directory.hs107
-rw-r--r--Utility/Env.hs63
-rw-r--r--Utility/Exception.hs59
-rw-r--r--Utility/FileMode.hs142
-rw-r--r--Utility/FileSystemEncoding.hs93
-rw-r--r--Utility/Format.hs178
-rw-r--r--Utility/Metered.hs116
-rw-r--r--Utility/Misc.hs153
-rw-r--r--Utility/Monad.hs69
-rw-r--r--Utility/PartialPrelude.hs68
-rw-r--r--Utility/Path.hs254
-rw-r--r--Utility/Process.hs356
-rw-r--r--Utility/QuickCheck.hs48
-rw-r--r--Utility/Rsync.hs152
-rw-r--r--Utility/SafeCommand.hs120
-rw-r--r--Utility/ThreadScheduler.hs69
-rw-r--r--Utility/Tmp.hs88
-rw-r--r--Utility/UserInfo.hs55
-rw-r--r--configure.hs6
-rw-r--r--debian/changelog28
-rw-r--r--debian/compat1
-rw-r--r--debian/control35
-rw-r--r--debian/copyright9
-rw-r--r--debian/manpages1
-rwxr-xr-xdebian/rules10
-rw-r--r--doc/index.mdwn51
-rw-r--r--git-repair.137
-rw-r--r--git-repair.cabal37
-rw-r--r--git-repair.hs119
66 files changed, 6627 insertions, 0 deletions
diff --git a/Build/Configure.hs b/Build/Configure.hs
new file mode 100644
index 0000000..4912122
--- /dev/null
+++ b/Build/Configure.hs
@@ -0,0 +1,30 @@
+{- 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 Build.Version
+import Git.Version
+
+tests :: [TestCase]
+tests =
+ [ TestCase "version" getVersion
+ , TestCase "git" $ requireCmd "git" "git --version >/dev/null"
+ , TestCase "git version" getGitVersion
+ ]
+
+getGitVersion :: Test
+getGitVersion = Config "gitversion" . StringConfig . show
+ <$> Git.Version.installed
+
+run :: [TestCase] -> IO ()
+run ts = do
+ args <- getArgs
+ config <- runTests ts
+ writeSysConfig config
+ whenM (isReleaseBuild) $
+ cabalSetup "git-repair.cabal"
diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs
new file mode 100644
index 0000000..8628ebe
--- /dev/null
+++ b/Build/TestConfig.hs
@@ -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
diff --git a/Build/Version.hs b/Build/Version.hs
new file mode 100644
index 0000000..98e0dbf
--- /dev/null
+++ b/Build/Version.hs
@@ -0,0 +1,69 @@
+{- Package version determination, for configure script. -}
+
+module Build.Version where
+
+import Data.Maybe
+import Control.Applicative
+import Data.List
+import System.Environment
+import System.Directory
+import Data.Char
+import System.Process
+
+import Build.TestConfig
+import Utility.Monad
+import Utility.Exception
+
+{- Set when making an official release. (Distribution vendors should set
+ - this too.) -}
+isReleaseBuild :: IO Bool
+isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD")
+
+{- Version is usually based on the major version from the changelog,
+ - plus the date of the last commit, plus the git rev of that commit.
+ - This works for autobuilds, ad-hoc builds, etc.
+ -
+ - If git or a git repo is not available, or something goes wrong,
+ - or this is a release build, just use the version from the changelog. -}
+getVersion :: Test
+getVersion = do
+ changelogversion <- getChangelogVersion
+ version <- ifM (isReleaseBuild)
+ ( return changelogversion
+ , catchDefaultIO changelogversion $ do
+ let major = takeWhile (/= '.') changelogversion
+ autoversion <- readProcess "sh"
+ [ "-c"
+ , "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'"
+ ] ""
+ if null autoversion
+ then return changelogversion
+ else return $ concat [ major, ".", autoversion ]
+ )
+ return $ Config "packageversion" (StringConfig version)
+
+getChangelogVersion :: IO String
+getChangelogVersion = do
+ changelog <- readFile "debian/changelog"
+ let verline = takeWhile (/= '\n') changelog
+ return $ middle (words verline !! 1)
+ where
+ middle = drop 1 . init
+
+{- Set up cabal file with version. -}
+cabalSetup :: FilePath -> IO ()
+cabalSetup cabalfile = do
+ version <- takeWhile (\c -> isDigit c || c == '.')
+ <$> getChangelogVersion
+ cabal <- readFile cabalfile
+ writeFile tmpcabalfile $ unlines $
+ map (setfield "Version" version) $
+ lines cabal
+ renameFile tmpcabalfile cabalfile
+ where
+ tmpcabalfile = cabalfile++".tmp"
+ setfield field value s
+ | fullfield `isPrefixOf` s = fullfield ++ value
+ | otherwise = s
+ where
+ fullfield = field ++ ": "
diff --git a/Build/make-sdist.sh b/Build/make-sdist.sh
new file mode 100755
index 0000000..5443e43
--- /dev/null
+++ b/Build/make-sdist.sh
@@ -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
diff --git a/Common.hs b/Common.hs
new file mode 100644
index 0000000..a6203b9
--- /dev/null
+++ b/Common.hs
@@ -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
diff --git a/GPL b/GPL
new file mode 100644
index 0000000..94a9ed0
--- /dev/null
+++ b/GPL
@@ -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>.
diff --git a/Git.hs b/Git.hs
new file mode 100644
index 0000000..cad4668
--- /dev/null
+++ b/Git.hs
@@ -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
diff --git a/Git/Branch.hs b/Git/Branch.hs
new file mode 100644
index 0000000..405fa10
--- /dev/null
+++ b/Git/Branch.hs
@@ -0,0 +1,153 @@
+{- 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.
+ -
+ - Without allowempy set, avoids making a commit if there is exactly
+ - one parent, and it has the same tree that would be committed.
+ -
+ - Unlike git-commit, does not run any hooks, or examine the work tree
+ - in any way.
+ -}
+commit :: Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
+commit allowempty message branch parentrefs repo = do
+ tree <- getSha "write-tree" $
+ pipeReadStrict [Param "write-tree"] repo
+ ifM (cancommit tree)
+ ( do
+ sha <- getSha "commit-tree" $ pipeWriteRead
+ (map Param $ ["commit-tree", show tree] ++ ps)
+ (Just $ flip hPutStr message) repo
+ update branch sha repo
+ return $ Just sha
+ , return Nothing
+ )
+ where
+ ps = concatMap (\r -> ["-p", show r]) parentrefs
+ cancommit tree
+ | allowempty = return True
+ | otherwise = case parentrefs of
+ [p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
+ _ -> return True
+
+commitAlways :: String -> Branch -> [Ref] -> Repo -> IO Sha
+commitAlways message branch parentrefs repo = fromJust
+ <$> commit True message branch parentrefs repo
+
+{- 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
+ ]
diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs
new file mode 100644
index 0000000..832ee8a
--- /dev/null
+++ b/Git/BuildVersion.hs
@@ -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
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
new file mode 100644
index 0000000..aee6bd1
--- /dev/null
+++ b/Git/CatFile.hs
@@ -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
diff --git a/Git/Command.hs b/Git/Command.hs
new file mode 100644
index 0000000..adcc53b
--- /dev/null
+++ b/Git/Command.hs
@@ -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 }
diff --git a/Git/Config.hs b/Git/Config.hs
new file mode 100644
index 0000000..b5c1be0
--- /dev/null
+++ b/Git/Config.hs
@@ -0,0 +1,198 @@
+{- 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 = ifM (doesDirectoryExist dotgit)
+ ( updateLocation' r $ Local dotgit Nothing
+ , updateLocation' r $ Local d Nothing
+ )
+ | otherwise = updateLocation' r $ Local dotgit (Just d)
+ where
+ dotgit = (d </> ".git")
+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
+ ]
diff --git a/Git/Construct.hs b/Git/Construct.hs
new file mode 100644
index 0000000..71a13f4
--- /dev/null
+++ b/Git/Construct.hs
@@ -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 = []
+ }
+
+
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
new file mode 100644
index 0000000..ee91a6b
--- /dev/null
+++ b/Git/CurrentRepo.hs
@@ -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 }
diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs
new file mode 100644
index 0000000..f460600
--- /dev/null
+++ b/Git/Destroyer.hs
@@ -0,0 +1,126 @@
+{- git repository destroyer
+ -
+ - Use with caution!
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Destroyer (
+ Damage(..),
+ generateDamage,
+ applyDamage
+) where
+
+import Common
+import Git
+import Utility.QuickCheck
+import Utility.FileMode
+
+import qualified Data.ByteString as B
+import Data.Word
+import System.PosixCompat.Types
+
+{- Ways to damange a git repository. -}
+data Damage = Damage DamageAction FileSelector
+ deriving (Read, Show)
+
+instance Arbitrary Damage where
+ arbitrary = Damage <$> arbitrary <*> arbitrary
+
+data DamageAction
+ = Empty
+ | Delete
+ | Reverse
+ | AppendGarbage B.ByteString
+ | PrependGarbage B.ByteString
+ | CorruptByte Int Word8
+ | ScrambleFileMode FileMode
+ deriving (Read, Show)
+
+instance Arbitrary DamageAction where
+ arbitrary = oneof
+ [ pure Empty
+ , pure Delete
+ , pure Reverse
+ , AppendGarbage <$> garbage
+ , PrependGarbage <$> garbage
+ , CorruptByte
+ <$> nonNegative arbitraryBoundedIntegral
+ <*> arbitrary
+ , ScrambleFileMode <$> nonNegative arbitrarySizedIntegral
+ ]
+ where
+ garbage = B.pack <$> arbitrary `suchThat` (not . null)
+
+{- To select a given file in a git repository, all files in the repository
+ - are enumerated, sorted, and this is used as an index
+ - into the list. (Wrapping around if higher than the length.) -}
+data FileSelector = FileSelector Int
+ deriving (Read, Show)
+
+instance Arbitrary FileSelector where
+ arbitrary = FileSelector <$> oneof
+ -- An early file in the git tree, tends to be the most
+ -- interesting when there are lots of files.
+ [ nonNegative arbitrarySizedIntegral
+ -- Totally random choice from any of the files in
+ -- the git tree, to ensure good coverage.
+ , nonNegative arbitraryBoundedIntegral
+ ]
+
+selectFile :: [FilePath] -> FileSelector -> FilePath
+selectFile sortedfs (FileSelector n) = sortedfs !! (n `mod` length sortedfs)
+
+{- Generates random Damage. -}
+generateDamage :: IO [Damage]
+generateDamage = sample' (arbitrary :: Gen Damage)
+
+{- Applies Damage to a Repo, in a reproducible fashion
+ - (as long as the Repo contains the same files each time). -}
+applyDamage :: [Damage] -> Repo -> IO ()
+applyDamage l r = do
+ contents <- sort . filter (not . skipped . takeFileName)
+ <$> dirContentsRecursive (localGitDir r)
+ forM_ l $ \(Damage action fileselector) -> do
+ let f = selectFile contents fileselector
+ -- Symlinks might be dangling, so are skipped.
+ -- If the file was already removed by a previous Damage,
+ -- it's skipped.
+ whenM (doesFileExist f) $
+ applyDamageAction action f
+ `catchIO` \e -> error ("Failed to apply " ++ show action ++ " " ++ show f ++ ": " ++ show e ++ "(total damage: " ++ show l ++ ")")
+ where
+ -- A broken .git/config is not recoverable.
+ skipped f = f `elem` [ "config" ]
+
+applyDamageAction :: DamageAction -> FilePath -> IO ()
+applyDamageAction Empty f = withSaneMode f $ do
+ nukeFile f
+ writeFile f ""
+applyDamageAction Reverse f = withSaneMode f $
+ B.writeFile f =<< B.reverse <$> B.readFile f
+applyDamageAction Delete f = nukeFile f
+applyDamageAction (AppendGarbage garbage) f = withSaneMode f $
+ B.appendFile f garbage
+applyDamageAction (PrependGarbage garbage) f = withSaneMode f $ do
+ b <- B.readFile f
+ B.writeFile f $ B.concat [garbage, b]
+-- When the byte is past the end of the file, wrap around.
+-- Does nothing to empty file.
+applyDamageAction (CorruptByte n garbage) f = withSaneMode f $ do
+ b <- B.readFile f
+ let len = B.length b
+ unless (len == 0) $ do
+ let n' = n `mod` len
+ let (prefix, rest) = B.splitAt n' b
+ B.writeFile f $ B.concat
+ [prefix
+ , B.singleton garbage
+ , B.drop 1 rest
+ ]
+applyDamageAction (ScrambleFileMode mode) f = setFileMode f mode
+
+withSaneMode :: FilePath -> IO () -> IO ()
+withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode])
diff --git a/Git/FilePath.hs b/Git/FilePath.hs
new file mode 100644
index 0000000..37d740f
--- /dev/null
+++ b/Git/FilePath.hs
@@ -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
diff --git a/Git/Filename.hs b/Git/Filename.hs
new file mode 100644
index 0000000..5e076d3
--- /dev/null
+++ b/Git/Filename.hs
@@ -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)
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
new file mode 100644
index 0000000..8d5b75b
--- /dev/null
+++ b/Git/Fsck.hs
@@ -0,0 +1,81 @@
+{- 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,
+ knownMissing,
+) where
+
+import Common
+import Git
+import Git.Command
+import Git.Sha
+import Utility.Batch
+
+import qualified Data.Set as S
+
+type MissingObjects = S.Set Sha
+
+data FsckResults = FsckFoundMissing MissingObjects | FsckFailed
+
+{- 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
+ let (command, params) = ("git", fsckParams r)
+ (command', params') <- if batchmode
+ then toBatchCommand (command, params)
+ else return (command, params)
+ (output, fsckok) <- processTranscript command' (toCommand params') Nothing
+ let objs = findShas output
+ badobjs <- findMissing objs r
+ if S.null badobjs && not fsckok
+ then return FsckFailed
+ else return $ FsckFoundMissing badobjs
+
+foundBroken :: FsckResults -> Bool
+foundBroken FsckFailed = True
+foundBroken (FsckFoundMissing s) = not (S.null s)
+
+knownMissing :: FsckResults -> MissingObjects
+knownMissing FsckFailed = S.empty
+knownMissing (FsckFoundMissing s) = s
+
+{- Finds objects that are missing from the git repsitory, or are corrupt.
+ -
+ - This does not use git cat-file --batch, because catting a corrupt
+ - object can cause it to crash, or to report incorrect size information.a
+ -}
+findMissing :: [Sha] -> Repo -> IO MissingObjects
+findMissing objs r = S.fromList <$> filterM (not <$$> present) objs
+ where
+ present o = either (const False) (const True) <$> tryIO (dump o)
+ dump o = runQuiet
+ [ Param "show"
+ , Param (show o)
+ ] r
+
+findShas :: String -> [Sha]
+findShas = catMaybes . map extractSha . concat . map words . lines
+
+fsckParams :: Repo -> [CommandParam]
+fsckParams = gitCommandLine $
+ [ Param "fsck"
+ , Param "--no-dangling"
+ , Param "--no-reflogs"
+ ]
diff --git a/Git/Index.hs b/Git/Index.hs
new file mode 100644
index 0000000..d9d5b03
--- /dev/null
+++ b/Git/Index.hs
@@ -0,0 +1,32 @@
+{- git index file stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Index where
+
+import Common
+import Git
+import Utility.Env
+
+{- Forces git to use the specified index file.
+ -
+ - Returns an action that will reset back to the default
+ - index file.
+ -
+ - Warning: Not thread safe.
+ -}
+override :: FilePath -> IO (IO ())
+override index = do
+ res <- getEnv var
+ void $ setEnv var index True
+ return $ void $ reset res
+ where
+ var = "GIT_INDEX_FILE"
+ reset (Just v) = setEnv var v True
+ reset _ = unsetEnv var
+
+indexFile :: Repo -> FilePath
+indexFile r = localGitDir r </> "index"
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
new file mode 100644
index 0000000..8aaa090
--- /dev/null
+++ b/Git/LsFiles.hs
@@ -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
+ }
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
new file mode 100644
index 0000000..956f9f5
--- /dev/null
+++ b/Git/LsTree.hs
@@ -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
diff --git a/Git/Objects.hs b/Git/Objects.hs
new file mode 100644
index 0000000..d9d2c67
--- /dev/null
+++ b/Git/Objects.hs
@@ -0,0 +1,35 @@
+{- .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
+import Git.Sha
+
+objectsDir :: Repo -> FilePath
+objectsDir r = localGitDir r </> "objects"
+
+packDir :: Repo -> FilePath
+packDir r = objectsDir r </> "pack"
+
+packIdxFile :: FilePath -> FilePath
+packIdxFile = flip replaceExtension "idx"
+
+listPackFiles :: Repo -> IO [FilePath]
+listPackFiles r = filter (".pack" `isSuffixOf`)
+ <$> catchDefaultIO [] (dirContents $ packDir r)
+
+listLooseObjectShas :: Repo -> IO [Sha]
+listLooseObjectShas r = catchDefaultIO [] $
+ mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)
+ <$> dirContentsRecursiveSkipping (== "pack") (objectsDir r)
+
+looseObjectFile :: Repo -> Sha -> FilePath
+looseObjectFile r sha = objectsDir r </> prefix </> rest
+ where
+ (prefix, rest) = splitAt 2 (show sha)
diff --git a/Git/Ref.hs b/Git/Ref.hs
new file mode 100644
index 0000000..0947293
--- /dev/null
+++ b/Git/Ref.hs
@@ -0,0 +1,139 @@
+{- 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 Git.Sha
+
+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
+
+{- Gets the sha of the tree a ref uses. -}
+tree :: Ref -> Repo -> IO (Maybe Sha)
+tree ref = extractSha <$$> pipeReadStrict
+ [ Param "rev-parse", Param (show ref ++ ":") ]
+
+{- 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)]
diff --git a/Git/RefLog.hs b/Git/RefLog.hs
new file mode 100644
index 0000000..3f41e8e
--- /dev/null
+++ b/Git/RefLog.hs
@@ -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)
+ ]
diff --git a/Git/Remote.hs b/Git/Remote.hs
new file mode 100644
index 0000000..9d969c4
--- /dev/null
+++ b/Git/Remote.hs
@@ -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
diff --git a/Git/Repair.hs b/Git/Repair.hs
new file mode 100644
index 0000000..5afa5f9
--- /dev/null
+++ b/Git/Repair.hs
@@ -0,0 +1,548 @@
+{- git repository recovery
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Repair (
+ runRepair,
+ runRepairOf,
+ successfulRepair,
+ cleanCorruptObjects,
+ retrieveMissingObjects,
+ resetLocalBranches,
+ removeTrackingBranches,
+ checkIndex,
+ missingIndex,
+ emptyGoodCommits,
+) where
+
+import Common
+import Git
+import Git.Command
+import Git.Objects
+import Git.Sha
+import Git.Types
+import Git.Fsck
+import Git.Index
+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 Utility.FileMode
+
+import qualified Data.Set as S
+import qualified Data.ByteString.Lazy as L
+import Data.Tuple.Utils
+
+{- Given a set of bad objects found by git fsck, which may not
+ - be complete, finds and removes all corrupt objects,
+ - and returns missing objects.
+ -}
+cleanCorruptObjects :: FsckResults -> Repo -> IO FsckResults
+cleanCorruptObjects fsckresults r = do
+ void $ explodePacks r
+ objs <- listLooseObjectShas r
+ mapM_ (tryIO . allowRead . looseObjectFile r) objs
+ bad <- findMissing objs r
+ void $ removeLoose r $ S.union bad (knownMissing fsckresults)
+ -- Rather than returning the loose objects that were removed, re-run
+ -- fsck. Other missing objects may have been in the packs,
+ -- and this way fsck will find them.
+ findBroken False r
+
+removeLoose :: Repo -> MissingObjects -> IO Bool
+removeLoose r s = do
+ fs <- filterM doesFileExist (map (looseObjectFile r) (S.toList s))
+ let count = length 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 = withTmpFileIn (localGitDir r) "pack" $ \tmp _ -> do
+ moveFile packfile tmp
+ nukeFile $ packIdxFile packfile
+ allowRead tmp
+ -- May fail, if pack file is corrupt.
+ void $ tryIO $
+ pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->
+ L.hPut h =<< L.readFile tmp
+
+{- 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 :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults
+retrieveMissingObjects missing referencerepo r
+ | not (foundBroken 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 (knownMissing 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 $ explodePacks tmpr
+ void $ copyObjects tmpr r
+ case stillmissing of
+ FsckFailed -> return $ FsckFailed
+ FsckFoundMissing s -> FsckFoundMissing <$> findMissing (S.toList s) r
+ , return stillmissing
+ )
+ pullremotes tmpr (rmt:rmts) fetchrefs ms
+ | not (foundBroken ms) = return ms
+ | otherwise = do
+ putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "."
+ ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr)
+ ( do
+ void $ explodePacks tmpr
+ void $ copyObjects tmpr r
+ case ms of
+ FsckFailed -> pullremotes tmpr rmts fetchrefs ms
+ FsckFoundMissing s -> do
+ stillmissing <- findMissing (S.toList s) r
+ pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing)
+ , pullremotes tmpr rmts fetchrefs ms
+ )
+ 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 objects, 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.
+ -
+ - Relies on packed refs being exploded before it's called.
+ -}
+getAllRefs :: Repo -> IO [Ref]
+getAllRefs r = map toref <$> dirContentsRecursive refdir
+ where
+ refdir = localGitDir r </> "refs"
+ toref = Ref . relPathDirToFile (localGitDir r)
+
+explodePackedRefsFile :: Repo -> IO ()
+explodePackedRefsFile r = do
+ let f = packedRefsFile r
+ whenM (doesFileExist f) $ do
+ rs <- mapMaybe parsePacked . lines
+ <$> catchDefaultIO "" (safeReadFile f)
+ forM_ rs makeref
+ nukeFile f
+ where
+ makeref (sha, ref) = do
+ let dest = localGitDir r ++ show ref
+ createDirectoryIfMissing True (parentDir dest)
+ unlessM (doesFileExist dest) $
+ writeFile dest (show sha)
+
+packedRefsFile :: Repo -> FilePath
+packedRefsFile r = localGitDir r </> "packed-refs"
+
+parsePacked :: String -> Maybe (Sha, Ref)
+parsePacked l = case words l of
+ (sha:ref:[])
+ | isJust (extractSha sha) && Ref.legal True ref ->
+ Just (Ref sha, Ref ref)
+ _ -> Nothing
+
+{- git-branch -d cannot be used to remove a branch that is directly
+ - pointing to a corrupt commit. -}
+nukeBranchRef :: Branch -> Repo -> IO ()
+nukeBranchRef b r = nukeFile $ localGitDir r </> show b
+
+{- Finds the most recent commit to a branch that does not need any
+ - of the missing objects. If the input branch is good as-is, returns it.
+ - 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
+ nukeFile (indexFile 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
+
+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
+
+{- Fix problems that would prevent repair from working at all
+ -
+ - A missing or corrupt .git/HEAD makes git not treat the repository as a
+ - git repo. If there is a git repo in a parent directory, it may move up
+ - the tree and use that one instead. So, cannot use `git show-ref HEAD` to
+ - test it.
+ -
+ - Explode the packed refs file, to simplify dealing with refs, and because
+ - fsck can complain about bad refs in it.
+ -}
+preRepair :: Repo -> IO ()
+preRepair g = do
+ unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do
+ nukeFile headfile
+ writeFile headfile "ref: refs/heads/master"
+ explodePackedRefsFile g
+ unless (repoIsLocalBare g) $ do
+ let f = indexFile g
+ void $ tryIO $ allowWrite f
+ where
+ headfile = localGitDir g </> "HEAD"
+ validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)
+
+{- Put it all together. -}
+runRepair :: Bool -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepair forced g = do
+ preRepair g
+ putStrLn "Running git fsck ..."
+ fsckresult <- findBroken False g
+ if foundBroken fsckresult
+ then runRepair' 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
+ preRepair g
+ runRepair' fsckresult forced referencerepo g
+
+runRepair' :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepair' fsckresult forced referencerepo g = do
+ missing <- cleanCorruptObjects fsckresult g
+ stillmissing <- retrieveMissingObjects missing referencerepo g
+ case stillmissing of
+ FsckFoundMissing s
+ | S.null s -> if repoIsLocalBare g
+ then successfulfinish S.empty []
+ else ifM (checkIndex S.empty g)
+ ( successfulfinish s []
+ , do
+ putStrLn "No missing objects found, but the index file is corrupt!"
+ if forced
+ then corruptedindex
+ else needforce S.empty
+ )
+ | otherwise -> if forced
+ then ifM (checkIndex s g)
+ ( continuerepairs s
+ , corruptedindex
+ )
+ else do
+ putStrLn $ unwords
+ [ show (S.size s)
+ , "missing objects could not be recovered!"
+ ]
+ unsuccessfulfinish s
+ FsckFailed
+ | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex S.empty g)
+ ( do
+ missing' <- cleanCorruptObjects FsckFailed g
+ case missing' of
+ FsckFailed -> return (False, S.empty, [])
+ FsckFoundMissing stillmissing' -> continuerepairs stillmissing'
+ , corruptedindex
+ )
+ | otherwise -> unsuccessfulfinish S.empty
+ 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
+ nukeFile (indexFile g)
+ -- The corrupted index can prevent fsck from finding other
+ -- problems, so re-run repair.
+ fsckresult' <- findBroken False g
+ result <- runRepairOf fsckresult' forced referencerepo 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 result
+
+ 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, [])
+
+successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool
+successfulRepair = fst3
+
+safeReadFile :: FilePath -> IO String
+safeReadFile f = do
+ allowRead f
+ readFileStrictAnyEncoding f
diff --git a/Git/Sha.hs b/Git/Sha.hs
new file mode 100644
index 0000000..ee1b6d6
--- /dev/null
+++ b/Git/Sha.hs
@@ -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'
diff --git a/Git/Types.hs b/Git/Types.hs
new file mode 100644
index 0000000..e63e930
--- /dev/null
+++ b/Git/Types.hs
@@ -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
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
new file mode 100644
index 0000000..3b33ac8
--- /dev/null
+++ b/Git/UpdateIndex.hs
@@ -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
diff --git a/Git/Url.hs b/Git/Url.hs
new file mode 100644
index 0000000..d383a6a
--- /dev/null
+++ b/Git/Url.hs
@@ -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"
diff --git a/Git/Version.hs b/Git/Version.hs
new file mode 100644
index 0000000..5ad1d59
--- /dev/null
+++ b/Git/Version.hs
@@ -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
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..ebbecdf
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,34 @@
+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 git-repair-test.log \
+ 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
+
+.PHONY: tags
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..03c23a3
--- /dev/null
+++ b/Setup.hs
@@ -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, [])
diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs
new file mode 100644
index 0000000..64400c8
--- /dev/null
+++ b/Utility/Applicative.hs
@@ -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 <$$>
diff --git a/Utility/Batch.hs b/Utility/Batch.hs
new file mode 100644
index 0000000..61026f1
--- /dev/null
+++ b/Utility/Batch.hs
@@ -0,0 +1,93 @@
+{- 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
+
+#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
+
+{- Makes a command be run by whichever of nice, ionice, and nocache
+ - are available in the path. -}
+type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam])
+
+getBatchCommandMaker :: IO BatchCommandMaker
+getBatchCommandMaker = do
+#ifndef mingw32_HOST_OS
+ nicers <- filterM (inPath . fst)
+ [ ("nice", [])
+ , ("ionice", ["-c3"])
+ , ("nocache", [])
+ ]
+ return $ \(command, params) ->
+ case nicers of
+ [] -> (command, params)
+ (first:rest) -> (fst first, map Param (snd first ++ concatMap (\p -> fst p : snd p) rest ++ [command]) ++ params)
+#else
+ return id
+#endif
+
+toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam])
+toBatchCommand v = do
+ batchmaker <- getBatchCommandMaker
+ return $ batchmaker v
+
+{- Runs a command in a way that's suitable for batch jobs that can be
+ - interrupted.
+ -
+ - 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
+ batchmaker <- getBatchCommandMaker
+ let (command', params') = batchmaker (command, params)
+ let p = proc command' $ toCommand params'
+ (_, _, _, 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
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
new file mode 100644
index 0000000..710d2af
--- /dev/null
+++ b/Utility/CoProcess.hs
@@ -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
diff --git a/Utility/Data.hs b/Utility/Data.hs
new file mode 100644
index 0000000..3592582
--- /dev/null
+++ b/Utility/Data.hs
@@ -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
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
new file mode 100644
index 0000000..4918d20
--- /dev/null
+++ b/Utility/Directory.hs
@@ -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
diff --git a/Utility/Env.hs b/Utility/Env.hs
new file mode 100644
index 0000000..cb73873
--- /dev/null
+++ b/Utility/Env.hs
@@ -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
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
new file mode 100644
index 0000000..cf2c615
--- /dev/null
+++ b/Utility/Exception.hs
@@ -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
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
new file mode 100644
index 0000000..46c6a31
--- /dev/null
+++ b/Utility/FileMode.hs
@@ -0,0 +1,142 @@
+{- 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]
+
+{- Turns a file's owner read bit back on. -}
+allowRead :: FilePath -> IO ()
+allowRead f = modifyFileMode f $ addModes [ownerReadMode]
+
+{- Allows owner and group to read and write to a file. -}
+groupSharedModes :: [FileMode]
+groupSharedModes =
+ [ ownerWriteMode, groupWriteMode
+ , ownerReadMode, groupReadMode
+ ]
+
+groupWriteRead :: FilePath -> IO ()
+groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
+
+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
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
new file mode 100644
index 0000000..ac105e7
--- /dev/null
+++ b/Utility/FileSystemEncoding.hs
@@ -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)
diff --git a/Utility/Format.hs b/Utility/Format.hs
new file mode 100644
index 0000000..e7a2751
--- /dev/null
+++ b/Utility/Format.hs
@@ -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)
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
new file mode 100644
index 0000000..f33ad44
--- /dev/null
+++ b/Utility/Metered.hs
@@ -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
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
new file mode 100644
index 0000000..68199c8
--- /dev/null
+++ b/Utility/Misc.hs
@@ -0,0 +1,153 @@
+{- 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
+import System.Exit
+#ifndef mingw32_HOST_OS
+import System.Posix.Process (getAnyProcessStatus)
+import Utility.Exception
+#endif
+
+import Utility.FileSystemEncoding
+import Utility.Monad
+
+{- 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
+
+{- Reads a file strictly, and using the FileSystemEncofing, so it will
+ - never crash on a badly encoded file. -}
+readFileStrictAnyEncoding :: FilePath -> IO String
+readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do
+ fileEncoding h
+ hClose h `after` hGetContentsStrict h
+
+{- 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
+
+exitBool :: Bool -> IO a
+exitBool False = exitFailure
+exitBool True = exitSuccess
diff --git a/Utility/Monad.hs b/Utility/Monad.hs
new file mode 100644
index 0000000..1ba43c5
--- /dev/null
+++ b/Utility/Monad.hs
@@ -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 ()
diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs
new file mode 100644
index 0000000..6efa093
--- /dev/null
+++ b/Utility/PartialPrelude.hs
@@ -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]
diff --git a/Utility/Path.hs b/Utility/Path.hs
new file mode 100644
index 0000000..b6214b2
--- /dev/null
+++ b/Utility/Path.hs
@@ -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
diff --git a/Utility/Process.hs b/Utility/Process.hs
new file mode 100644
index 0000000..398e8a3
--- /dev/null
+++ b/Utility/Process.hs
@@ -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
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
new file mode 100644
index 0000000..82af09f
--- /dev/null
+++ b/Utility/QuickCheck.hs
@@ -0,0 +1,48 @@
+{- QuickCheck with additional instances
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Utility.QuickCheck
+ ( module X
+ , module Utility.QuickCheck
+ ) where
+
+import Test.QuickCheck as X
+import Data.Time.Clock.POSIX
+import System.Posix.Types
+import qualified Data.Map as M
+import Control.Applicative
+
+instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
+ arbitrary = M.fromList <$> arbitrary
+
+{- Times before the epoch are excluded. -}
+instance Arbitrary POSIXTime where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+instance Arbitrary EpochTime where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+{- Pids are never negative, or 0. -}
+instance Arbitrary ProcessID where
+ arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)
+
+{- Inodes are never negative. -}
+instance Arbitrary FileID where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+{- File sizes are never negative. -}
+instance Arbitrary FileOffset where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+nonNegative :: (Num a, Ord a) => Gen a -> Gen a
+nonNegative g = g `suchThat` (>= 0)
+
+positive :: (Num a, Ord a) => Gen a -> Gen a
+positive g = g `suchThat` (> 0)
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
new file mode 100644
index 0000000..5f322a0
--- /dev/null
+++ b/Utility/Rsync.hs
@@ -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) ""
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
new file mode 100644
index 0000000..c8318ec
--- /dev/null
+++ b/Utility/SafeCommand.hs
@@ -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
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
new file mode 100644
index 0000000..c3e871c
--- /dev/null
+++ b/Utility/ThreadScheduler.hs
@@ -0,0 +1,69 @@
+{- thread scheduling
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Bas van Dijk & Roel van Dijk
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.ThreadScheduler where
+
+import Common
+
+import Control.Concurrent
+#ifndef mingw32_HOST_OS
+import System.Posix.Signals
+#ifndef __ANDROID__
+import System.Posix.Terminal
+#endif
+#endif
+
+newtype Seconds = Seconds { fromSeconds :: Int }
+ deriving (Eq, Ord, Show)
+
+type Microseconds = Integer
+
+{- Runs an action repeatedly forever, sleeping at least the specified number
+ - of seconds in between. -}
+runEvery :: Seconds -> IO a -> IO a
+runEvery n a = forever $ do
+ threadDelaySeconds n
+ a
+
+threadDelaySeconds :: Seconds -> IO ()
+threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)
+
+{- Like threadDelay, but not bounded by an Int.
+ -
+ - There is no guarantee that the thread will be rescheduled promptly when the
+ - delay has expired, but the thread will never continue to run earlier than
+ - specified.
+ -
+ - Taken from the unbounded-delay package to avoid a dependency for 4 lines
+ - of code.
+ -}
+unboundDelay :: Microseconds -> IO ()
+unboundDelay time = do
+ let maxWait = min time $ toInteger (maxBound :: Int)
+ threadDelay $ fromInteger maxWait
+ when (maxWait /= time) $ unboundDelay (time - maxWait)
+
+{- Pauses the main thread, letting children run until program termination. -}
+waitForTermination :: IO ()
+waitForTermination = do
+ lock <- newEmptyMVar
+#ifndef mingw32_HOST_OS
+ let check sig = void $
+ installHandler sig (CatchOnce $ putMVar lock ()) Nothing
+ check softwareTermination
+#ifndef __ANDROID__
+ whenM (queryTerminal stdInput) $
+ check keyboardSignal
+#endif
+#endif
+ takeMVar lock
+
+oneSecond :: Microseconds
+oneSecond = 1000000
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
new file mode 100644
index 0000000..186cd12
--- /dev/null
+++ b/Utility/Tmp.hs
@@ -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
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
new file mode 100644
index 0000000..9c3bfd4
--- /dev/null
+++ b/Utility/UserInfo.hs
@@ -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
diff --git a/configure.hs b/configure.hs
new file mode 100644
index 0000000..15833e6
--- /dev/null
+++ b/configure.hs
@@ -0,0 +1,6 @@
+{- configure program -}
+
+import Build.Configure
+
+main :: IO ()
+main = run tests
diff --git a/debian/changelog b/debian/changelog
new file mode 100644
index 0000000..1eb84fc
--- /dev/null
+++ b/debian/changelog
@@ -0,0 +1,28 @@
+git-repair (1.20131203) unstable; urgency=low
+
+ * Fix build deps. Closes: #731179
+
+ -- Joey Hess <joeyh@debian.org> Tue, 03 Dec 2013 15:02:21 -0400
+
+git-repair (1.20131122) unstable; urgency=low
+
+ * Added test mode, which can be used to randomly corrupt test
+ repositories, in reproducible ways, which allows easy
+ corruption-driven-development.
+ * Improve repair code in the case where the index file is corrupt,
+ and this hides other problems.
+ * Write a dummy .git/HEAD if the file is missing or corrupt, as
+ git otherwise will not treat the repository as a git repo.
+ * Improve fsck code to find badly corrupted objects that crash git fsck
+ before it can complain about them.
+ * Fixed crashes on bad file encodings.
+ * Can now run 10000 tests (git-repair --test -n 10000 --force)
+ with 0 failures.
+
+ -- Joey Hess <joeyh@debian.org> Fri, 22 Nov 2013 11:16:03 -0400
+
+git-repair (1.20131118) unstable; urgency=low
+
+ * First release
+
+ -- Joey Hess <joeyh@debian.org> Mon, 18 Nov 2013 13:38:12 -0400
diff --git a/debian/compat b/debian/compat
new file mode 100644
index 0000000..ec63514
--- /dev/null
+++ b/debian/compat
@@ -0,0 +1 @@
+9
diff --git a/debian/control b/debian/control
new file mode 100644
index 0000000..cecd327
--- /dev/null
+++ b/debian/control
@@ -0,0 +1,35 @@
+Source: git-repair
+Section: utils
+Priority: optional
+Build-Depends:
+ debhelper (>= 9),
+ ghc,
+ git,
+ libghc-missingh-dev,
+ libghc-hslogger-dev,
+ libghc-network-dev,
+ libghc-extensible-exceptions-dev,
+ libghc-unix-compat-dev,
+ libghc-ifelse-dev,
+ libghc-text-dev,
+ libghc-quickcheck2-dev,
+ libghc-utf8-string-dev,
+ libghc-async-dev,
+ libghc-optparse-applicative-dev
+Maintainer: Joey Hess <joeyh@debian.org>
+Standards-Version: 3.9.4
+Vcs-Git: git://git-repair.branchable.com/
+Homepage: http://git-repair.branchable.com/
+
+Package: git-repair
+Architecture: any
+Section: utils
+Depends: ${misc:Depends}, ${shlibs:Depends}, git, rsync
+Description: repair various forms of damage to git repositorie
+ 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.
+ .
+ As well as avoiding the need to rm -rf a damaged repository and re-clone,
+ using git-repair can help rescue commits you've made to the damaged
+ repository and not yet pushed out.
diff --git a/debian/copyright b/debian/copyright
new file mode 100644
index 0000000..9d7912f
--- /dev/null
+++ b/debian/copyright
@@ -0,0 +1,9 @@
+Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
+Source: native package
+
+Files: *
+Copyright: © 2013 Joey Hess <joey@kitenet.net>
+License: GPL-3+
+ The full text of version 3 of the GPL is distributed as doc/GPL in
+ this package's source, or in /usr/share/common-licenses/GPL-3 on
+ Debian systems.
diff --git a/debian/manpages b/debian/manpages
new file mode 100644
index 0000000..4cad191
--- /dev/null
+++ b/debian/manpages
@@ -0,0 +1 @@
+git-repair.1
diff --git a/debian/rules b/debian/rules
new file mode 100755
index 0000000..4d8fa21
--- /dev/null
+++ b/debian/rules
@@ -0,0 +1,10 @@
+#!/usr/bin/make -f
+
+# Avoid using cabal, as it writes to $HOME
+export CABAL=./Setup
+
+# Do use the changelog's version number, rather than making one up.
+export RELEASE_BUILD=1
+
+%:
+ dh $@
diff --git a/doc/index.mdwn b/doc/index.mdwn
new file mode 100644
index 0000000..1d9a7a9
--- /dev/null
+++ b/doc/index.mdwn
@@ -0,0 +1,51 @@
+`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.
+
+As well as avoiding the need to rm -rf a damaged repository and re-clone,
+using git-repair can help rescue commits you've made to the damaged
+repository and not yet pushed out.
+
+## download
+
+* `git clone git://git-repair.branchable.com/ git-repair`
+* from [Hackage](http://hackage.haskell.org/package/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.
diff --git a/git-repair.1 b/git-repair.1
new file mode 100644
index 0000000..146840f
--- /dev/null
+++ b/git-repair.1
@@ -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
diff --git a/git-repair.cabal b/git-repair.cabal
new file mode 100644
index 0000000..c9374b0
--- /dev/null
+++ b/git-repair.cabal
@@ -0,0 +1,37 @@
+Name: git-repair
+Version: 1.20131122
+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-repair.branchable.com/
+Category: Utility
+Synopsis: repairs a damanged git repisitory
+Description:
+ 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.
+ .
+ As well as avoiding the need to rm -rf a damaged repository and re-clone,
+ using git-repair can help rescue commits you've made to the damaged
+ repository and not yet pushed out.
+
+Executable git-repair
+ Main-Is: git-repair.hs
+ GHC-Options: -Wall -threaded
+ Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,
+ network, extensible-exceptions, unix-compat, bytestring,
+ base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck,
+ utf8-string, async, optparse-applicative
+
+ if (! os(windows))
+ Build-Depends: unix
+
+source-repository head
+ type: git
+ location: git://git-repair.branchable.com/
diff --git a/git-repair.hs b/git-repair.hs
new file mode 100644
index 0000000..0aedc27
--- /dev/null
+++ b/git-repair.hs
@@ -0,0 +1,119 @@
+{- git-repair program
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+import Options.Applicative
+
+import Common
+import qualified Git.CurrentRepo
+import qualified Git.Repair
+import qualified Git.Config
+import qualified Git.Construct
+import qualified Git.Destroyer
+import qualified Git.Fsck
+import Utility.Tmp
+
+data Settings = Settings
+ { forced :: Bool
+ , testMode :: Bool
+ , retryTestMode :: Bool
+ , numTests :: Int
+ }
+
+parseSettings :: Parser Settings
+parseSettings = Settings
+ <$> switch
+ ( long "force"
+ <> help "Force repair, even if data is lost"
+ )
+ <*> switch
+ ( long "test"
+ <> help "Clone local repo, damage the clone, and test repair"
+ )
+ <*> switch
+ ( long "retry"
+ <> help "Retry tests in git-repair-test.log"
+ )
+ <*> option
+ ( long "numtests"
+ <> short 'n'
+ <> metavar "N"
+ <> help "Run N tests"
+ <> value 1
+ )
+
+main :: IO ()
+main = execParser opts >>= go
+ where
+ opts = info (helper <*> parseSettings) desc
+ desc = fullDesc
+ <> header "git-repair - repair a damanged git repository"
+ go settings
+ | testMode settings = test settings
+ | retryTestMode settings = retryTest settings
+ | otherwise = repair settings
+
+repair :: Settings -> IO ()
+repair settings = do
+ g <- Git.Config.read =<< Git.CurrentRepo.get
+ ifM (Git.Repair.successfulRepair <$> Git.Repair.runRepair (forced settings) g)
+ ( exitSuccess
+ , exitFailure
+ )
+
+test :: Settings -> IO ()
+test settings = do
+ forM_ [1 .. numTests settings] $ \n -> do
+ putStrLn $ "** Test " ++ show n ++ "/" ++ show (numTests settings)
+ damage <- Git.Destroyer.generateDamage
+ logDamage damage
+ runTest settings damage
+ allOk
+
+retryTest :: Settings -> IO ()
+retryTest settings = do
+ l <- map Prelude.read . lines <$> readFile logFile
+ forM_ l $ \damage ->
+ runTest settings damage
+ allOk
+
+runTest :: Settings -> [Git.Destroyer.Damage] -> IO ()
+runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do
+ let cloneloc = tmpdir </> "clone"
+ cloned <- boolSystem "git"
+ [ Param "clone"
+ , Param "--no-hardlinks"
+ , File "."
+ , File cloneloc
+ ]
+ unless cloned $
+ error $ "failed to clone this repo"
+ g <- Git.Config.read =<< Git.Construct.fromPath cloneloc
+ Git.Destroyer.applyDamage damage g
+ repairstatus <- catchMaybeIO $ Git.Repair.successfulRepair
+ <$> Git.Repair.runRepair (forced settings) g
+ case repairstatus of
+ Just True -> testResult repairstatus
+ . Just . not . Git.Fsck.foundBroken
+ =<< Git.Fsck.findBroken False g
+ _ -> testResult repairstatus Nothing
+
+-- Pass test result and fsck result
+testResult :: (Maybe Bool) -> (Maybe Bool) -> IO ()
+testResult (Just True) (Just True) = putStrLn "** repair succeeded"
+testResult (Just True) (Just False) = error "** repair succeeded, but final fsck failed"
+testResult _ _ = error "** repair failed"
+
+allOk :: IO ()
+allOk = do
+ putStrLn ""
+ putStrLn "All tests ok!"
+
+logDamage :: [Git.Destroyer.Damage] -> IO ()
+logDamage damage = appendFile logFile $ show damage ++ "\n"
+
+logFile :: FilePath
+logFile = "git-repair-test.log"