Merge from git-annex.

15 files changed, 222 insertions, 86 deletions

diff --git a/Git.hs b/Git.hs
index 55b44a9..c9750a3 100644
--- a/Git.hs
+++ b/Git.hs
@@ -30,6 +30,8 @@ module Git (
 	attributes,
 	hookPath,
 	assertLocal,
+	adjustPath,
+	relPath,
 ) where
 
 import Network.URI (uriPath, uriScheme, unEscapeString)
@@ -139,3 +141,29 @@ hookPath script repo = do
 #else
 	isexecutable f = isExecutable . fileMode <$> getFileStatus f
 #endif
+
+{- Makes the path to a local Repo be relative to the cwd. -}
+relPath :: Repo -> IO Repo
+relPath = adjustPath torel
+  where
+	torel p = do
+		p' <- relPathCwdToFile p
+		if null p'
+			then return "."
+			else return p'
+
+{- Adusts the path to a local Repo using the provided function. -}
+adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo
+adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
+	d' <- f d
+	w' <- maybe (pure Nothing) (Just <$$> f) w
+	return $ r 
+		{ location = l 
+			{ gitdir = d'
+			, worktree = w'
+			}
+		}
+adjustPath f r@(Repo { location = LocalUnknown d }) = do
+	d' <- f d
+	return $ r { location = LocalUnknown d' }
+adjustPath _ r = pure r
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 0b7d888..5c6135d 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -43,6 +43,9 @@ currentUnsafe r = parse . firstLine
 		| null l = Nothing
 		| otherwise = Just $ Git.Ref l
 
+currentSha :: Repo -> IO (Maybe Git.Sha)
+currentSha r = maybe (pure Nothing) (`Git.Ref.sha` r) =<< current r
+
 {- Checks if the second branch has any commits not present on the first
  - branch. -}
 changed :: Branch -> Branch -> Repo -> IO Bool
diff --git a/Git/Construct.hs b/Git/Construct.hs
index eed2b99..3c6013a 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -46,8 +46,8 @@ fromCwd = getCurrentDirectory >>= seekUp
 		r <- checkForRepo dir
 		case r of
 			Nothing -> case parentDir dir of
-				"" -> return Nothing
-				d -> seekUp d
+				Nothing -> return Nothing
+				Just d -> seekUp d
 			Just loc -> Just <$> newFrom loc
 
 {- Local Repo constructor, accepts a relative or absolute path. -}
diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs
new file mode 100644
index 0000000..2389b69
--- /dev/null
+++ b/Git/DiffTreeItem.hs
@@ -0,0 +1,24 @@
+{- git diff-tree item
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.DiffTreeItem (
+	DiffTreeItem(..),
+) where
+
+import System.Posix.Types
+
+import Git.FilePath
+import Git.Types
+
+data DiffTreeItem = DiffTreeItem
+	{ srcmode :: FileMode
+	, dstmode :: FileMode
+	, srcsha :: Sha -- nullSha if file was added
+	, dstsha :: Sha -- nullSha if file was deleted
+	, status :: String
+	, file :: TopFilePath
+	} deriving Show
diff --git a/Git/Index.hs b/Git/Index.hs
index c42ac42..7145bb9 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -11,6 +11,9 @@ import Common
 import Git
 import Utility.Env
 
+indexEnv :: String
+indexEnv = "GIT_INDEX_FILE"
+
 {- Forces git to use the specified index file.
  -
  - Returns an action that will reset back to the default
@@ -25,7 +28,7 @@ override index = do
 	return $ reset res
   where
 	var = "GIT_INDEX_FILE"
-	reset (Just v) = setEnv var v True
+	reset (Just v) = setEnv indexEnv v True
 	reset _ = unsetEnv var
 
 indexFile :: Repo -> FilePath
@@ -34,3 +37,19 @@ indexFile r = localGitDir r </> "index"
 {- Git locks the index by creating this file. -}
 indexFileLock :: Repo -> FilePath
 indexFileLock r = indexFile r ++ ".lock"
+
+{- When the pre-commit hook is run, and git commit has been run with
+ - a file or files specified to commit, rather than committing the staged
+ - index, git provides the pre-commit hook with a "false index file".
+ -
+ - Changes made to this index will influence the commit, but won't
+ - affect the real index file.
+ -
+ - This detects when we're in this situation, using a heuristic, which
+ - might be broken by changes to git. Any use of this should have a test
+ - case to make sure it works.
+ -}
+haveFalseIndex :: IO Bool
+haveFalseIndex = maybe (False) check <$> getEnv indexEnv
+  where
+	check f = "next-index" `isPrefixOf` takeFileName f
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 77a592b..5731138 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -241,7 +241,7 @@ explodePackedRefsFile r = do
   where
 	makeref (sha, ref) = do
 		let dest = localGitDir r </> fromRef ref
-		createDirectoryIfMissing True (parentDir dest)
+		createDirectoryIfMissing True (takeDirectory dest)
 		unlessM (doesFileExist dest) $
 			writeFile dest (fromRef sha)
 
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index ecd154a..613596d 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -19,7 +19,8 @@ module Git.UpdateIndex (
 	updateIndexLine,
 	stageFile,
 	unstageFile,
-	stageSymlink
+	stageSymlink,
+	stageDiffTreeItem,
 ) where
 
 import Common
@@ -28,6 +29,7 @@ import Git.Types
 import Git.Command
 import Git.FilePath
 import Git.Sha
+import qualified Git.DiffTreeItem as Diff
 
 {- Streamers are passed a callback and should feed it lines in the form
  - read by update-index, and generated by ls-tree. -}
@@ -95,7 +97,10 @@ stageFile sha filetype file repo = do
 unstageFile :: FilePath -> Repo -> IO Streamer
 unstageFile file repo = do
 	p <- toTopFilePath file repo
-	return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
+	return $ unstageFile' p
+
+unstageFile' :: TopFilePath -> Streamer
+unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
 
 {- A streamer that adds a symlink to the index. -}
 stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
@@ -106,5 +111,11 @@ stageSymlink file sha repo = do
 		<*> toTopFilePath file repo
 	return $ pureStreamer line
 
+{- A streamer that applies a DiffTreeItem to the index. -}
+stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer
+stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of
+	Nothing -> unstageFile' (Diff.file d)
+	Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
+
 indexPath :: TopFilePath -> InternalGitPath
 indexPath = toInternalGitPath . getTopFilePath
diff --git a/Git/Version.hs b/Git/Version.hs
index 5c61f85..73ce2f8 100644
--- a/Git/Version.hs
+++ b/Git/Version.hs
@@ -5,18 +5,17 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Git.Version where
+module Git.Version (
+	installed,
+	older,
+	normalize,
+	GitVersion,
+) where
 
 import Common
+import Utility.DottedVersion
 
-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
+type GitVersion = DottedVersion
 
 installed :: IO GitVersion
 installed = normalize . extract <$> readProcess "git" ["--version"]
@@ -25,19 +24,7 @@ installed = normalize . extract <$> readProcess "git" ["--version"]
 		[] -> ""
 		(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
+older :: String -> IO Bool
+older n = do
+	v <- installed
+	return $ v < normalize n 
diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs
new file mode 100644
index 0000000..14aa16d
--- /dev/null
+++ b/Utility/DottedVersion.hs
@@ -0,0 +1,36 @@
+{- dotted versions, such as 1.0.1
+ -
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.DottedVersion where
+
+import Common
+
+data DottedVersion = DottedVersion String Integer
+	deriving (Eq)
+
+instance Ord DottedVersion where
+	compare (DottedVersion _ x) (DottedVersion _ y) = compare x y
+
+instance Show DottedVersion where
+	show (DottedVersion s _) = s
+
+{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to
+ - a somewhat arbitrary integer representation. -}
+normalize :: String -> DottedVersion
+normalize v = DottedVersion v $ 
+	sum $ mult 1 $ reverse $ extend precision $ take precision $
+		map readi $ split "." v
+  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/Utility/Metered.hs b/Utility/Metered.hs
index f27eee2..e4f3b44 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -143,3 +143,36 @@ defaultChunkSize = 32 * k - chunkOverhead
   where
 	k = 1024
 	chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific
+
+{- Parses the String looking for a command's 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 command's output to be read in any desired size chunk, or
+ - even one character at a time.
+ -}
+type ProgressParser = String -> (Maybe BytesProcessed, String)
+
+{- Runs a command and runs a ProgressParser on its output, in order
+ - to update the meter. The command's output is also sent to stdout. -}
+commandMeter :: ProgressParser -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool
+commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $
+	withHandle StdoutHandle createProcessSuccess p $
+		feedprogress zeroBytesProcessed []
+  where
+	p = proc cmd (toCommand 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') = progressparser (buf++s)
+				case mbytes of
+					Nothing -> feedprogress prev buf' h
+					(Just bytes) -> do
+						when (bytes /= prev) $
+							meterupdate bytes
+						feedprogress bytes buf' h
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 9035cbc..7f03491 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -21,6 +21,7 @@ import Control.Applicative
 import qualified System.FilePath.Posix as Posix
 #else
 import System.Posix.Files
+import Utility.Exception
 #endif
 
 import qualified "MissingH" System.Path as MissingH
@@ -76,14 +77,12 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos
 	todos = replace "/" "\\"
 #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
+{- Just the parent directory of a path, or Nothing if the path has no
+ - parent (ie for "/") -}
+parentDir :: FilePath -> Maybe FilePath
 parentDir dir
-	| null dirs = ""
-	| otherwise = joinDrive drive (join s $ init dirs)
+	| null dirs = Nothing
+	| otherwise = Just $ joinDrive drive (join s $ init dirs)
   where
 	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
 	(drive, path) = splitDrive dir
@@ -93,8 +92,8 @@ parentDir dir
 prop_parentDir_basics :: FilePath -> Bool
 prop_parentDir_basics dir
 	| null dir = True
-	| dir == "/" = parentDir dir == ""
-	| otherwise = p /= dir
+	| dir == "/" = parentDir dir == Nothing
+	| otherwise = p /= Just dir
   where
 	p = parentDir dir
 
@@ -255,7 +254,9 @@ fileNameLengthLimit :: FilePath -> IO Int
 fileNameLengthLimit _ = return 255
 #else
 fileNameLengthLimit dir = do
-	l <- fromIntegral <$> getPathVar dir FileNameLimit
+	-- getPathVar can fail due to statfs(2) overflow
+	l <- catchDefaultIO 0 $
+		fromIntegral <$> getPathVar dir FileNameLimit
 	if l <= 0
 		then return 255
 		else return $ minimum [l, 255]
@@ -267,7 +268,8 @@ fileNameLengthLimit dir = do
  - sane FilePath.
  -
  - All spaces and punctuation and other wacky stuff are replaced
- - with '_', except for '.' "../" will thus turn into ".._", which is safe.
+ - with '_', except for '.'
+ - "../" will thus turn into ".._", which is safe.
  -}
 sanitizeFilePath :: String -> FilePath
 sanitizeFilePath = map sanitize
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index 8dee609..ed1eab6 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -5,6 +5,8 @@
  - License: BSD-2-clause
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Utility.Rsync where
 
 import Common
@@ -53,37 +55,18 @@ 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. -}
+ - Fix up the Params appropriately. -}
 rsyncParamsFixup :: [CommandParam] -> [CommandParam]
+#ifdef mingw32_HOST_OS
 rsyncParamsFixup = map fixup
   where
 	fixup (File f) = File (toCygPath f)
+	fixup (Param s)
+		| rsyncUrlIsPath s = Param (toCygPath s)
 	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 = catchBoolIO $ 
-	withHandle StdoutHandle createProcessSuccess p (feedprogress 0 [])
-  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
+#else
+rsyncParamsFixup = id
+#endif
 
 {- Checks if an rsync url involves the remote shell (ssh or rsh).
  - Use of such urls with rsync requires additional shell
@@ -103,17 +86,21 @@ rsyncUrlIsShell s
 {- Checks if a rsync url is really just a local path. -}
 rsyncUrlIsPath :: String -> Bool
 rsyncUrlIsPath s
+#ifdef mingw32_HOST_OS
+	| not (null (takeDrive s)) = True
+#endif
 	| 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.
+{- Runs rsync, but intercepts its progress output and updates a meter.
+ - The progress output is also output to stdout. 
  -
- - Strategy: Look for chunks prefixed with \r (rsync writes a \r before
+ - The params must enable rsync's --progress mode for this to work.
+ -}
+rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool
+rsyncProgress meterupdate = commandMeter parseRsyncProgress meterupdate "rsync" . rsyncParamsFixup
+
+{- 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,
@@ -122,20 +109,23 @@ rsyncUrlIsPath s
  - In some locales, the number will have one or more commas in the middle
  - of it.
  -}
-parseRsyncProgress :: String -> (Maybe Integer, String)
+parseRsyncProgress :: ProgressParser
 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)
+		Just b -> (Just (toBytesProcessed 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 :: String -> Maybe Integer
 	parsebytes s = case break isSpace s of
 		([], _) -> Nothing
 		(_, []) -> Nothing
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index edd82f5..7599cdd 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -24,8 +24,8 @@ 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 = bracket setup cleanup use
+viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()
+viaTmp a file content = bracketIO setup cleanup use
   where
 	(dir, base) = splitFileName file
 	template = base ++ ".tmp"
@@ -36,9 +36,9 @@ viaTmp a file content = bracket setup cleanup use
 		_ <- tryIO $ hClose h
 		tryIO $ removeFile tmpfile
 	use (tmpfile, h) = do
-		hClose h
+		liftIO $ hClose h
 		a tmpfile content
-		rename tmpfile file
+		liftIO $ rename 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. -}
@@ -61,15 +61,15 @@ withTmpFileIn tmpdir template a = bracket create remove use
 {- 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 :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a
 withTmpDir template a = do
-	tmpdir <- catchDefaultIO "." getTemporaryDirectory
+	tmpdir <- liftIO $ 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
+withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
+withTmpDirIn tmpdir template = bracketIO create remove
   where
 	remove d = whenM (doesDirectoryExist d) $ do
 #if mingw32_HOST_OS
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index 1a557c9..c82f040 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -13,8 +13,10 @@ module Utility.UserInfo (
 	myUserGecos,
 ) where
 
-import Control.Applicative
 import System.PosixCompat
+#ifndef mingw32_HOST_OS
+import Control.Applicative
+#endif
 
 import Utility.Env
 
diff --git a/debian/changelog b/debian/changelog
index b86f51f..772473b 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -2,6 +2,7 @@ git-repair (1.20141028) UNRELEASED; urgency=medium
 
   * Debian package is now maintained by Gergely Nagy.
   * Fix build with process 1.2.1.0.
+  * Merge from git-annex.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 11 Nov 2014 17:06:17 -0400