merge from git-annex

10 files changed, 62 insertions, 30 deletions

diff --git a/Git/Command.hs b/Git/Command.hs
index adcc53b..4c338ba 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -128,9 +128,14 @@ leaveZombie = fst
 
 {- Runs a git command as a coprocess. -}
 gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle
-gitCoProcessStart restartable params repo = CoProcess.start restartable "git"
+gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git"
 	(toCommand $ gitCommandLine params repo)
 	(gitEnv repo)
+  where
+  	{- If a long-running git command like cat-file --batch
+	 - crashes, it will likely start up again ok. If it keeps crashing
+	 - 10 times, something is badly wrong. -}
+	numrestarts = if restartable then 10 else 0
 
 gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess
 gitCreateProcess params repo =
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index 8aaa090..e155845 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -66,11 +66,12 @@ 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. -}
+{- Files that have been modified or are not checked into git (and are not
+ - ignored). -}
 modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
 modifiedOthers l repo = pipeNullSplit params repo
   where
-	params = [Params "ls-files --modified --others -z --"] ++ map File l
+	params = [Params "ls-files --modified --others --exclude-standard -z --"] ++ map File l
 
 {- Returns a list of all files that are staged for commit. -}
 staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
diff --git a/Git/Objects.hs b/Git/Objects.hs
index d9d2c67..bb492f5 100644
--- a/Git/Objects.hs
+++ b/Git/Objects.hs
@@ -27,7 +27,7 @@ listPackFiles r = filter (".pack" `isSuffixOf`)
 listLooseObjectShas :: Repo -> IO [Sha]
 listLooseObjectShas r = catchDefaultIO [] $
 	mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)
-		<$> dirContentsRecursiveSkipping (== "pack") (objectsDir r)
+		<$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r)
 
 looseObjectFile :: Repo -> Sha -> FilePath
 looseObjectFile r sha = objectsDir r </> prefix </> rest
diff --git a/Utility/Batch.hs b/Utility/Batch.hs
index 61026f1..3f21478 100644
--- a/Utility/Batch.hs
+++ b/Utility/Batch.hs
@@ -52,7 +52,11 @@ getBatchCommandMaker = do
 #ifndef mingw32_HOST_OS
 	nicers <- filterM (inPath . fst)
 		[ ("nice", [])
+#ifndef __ANDROID__
+		-- Android's ionice does not allow specifying a command,
+		-- so don't use it.
 		, ("ionice", ["-c3"])
+#endif
 		, ("nocache", [])
 		]
 	return $ \(command, params) ->
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index 710d2af..c113401 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -30,15 +30,15 @@ data CoProcessState = CoProcessState
 	}
 
 data CoProcessSpec = CoProcessSpec
-	{ coProcessRestartable :: Bool
+	{ coProcessNumRestarts :: Int
 	, 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
+start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
+start numrestarts cmd params env = do
+	s <- start' $ CoProcessSpec numrestarts cmd params env
 	newMVar s
 
 start' :: CoProcessSpec -> IO CoProcessState
@@ -66,7 +66,7 @@ query ch send receive = do
 				return
   where
   	restartable s a cont
-		| coProcessRestartable (coProcessSpec s) =
+		| coProcessNumRestarts (coProcessSpec s) > 0 =
 			maybe restart cont =<< catchMaybeIO a
 		| otherwise = cont =<< a
 	restart = do
@@ -75,7 +75,8 @@ query ch send receive = do
 			hClose $ coProcessTo s
 			hClose $ coProcessFrom s
 		void $ waitForProcess $ coProcessPid s
-		s' <- start' (coProcessSpec s)
+		s' <- start' $ (coProcessSpec s)
+			{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 }
 		putMVar ch s'
 		query ch send receive
 
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 4918d20..6caee7e 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -35,14 +35,18 @@ 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,
+ - and lazily.
+ -
+ - Does not follow symlinks to other subdirectories.
+ -
+ - When the directory does not exist, no exception is thrown,
  - instead, [] is returned. -}
 dirContentsRecursive :: FilePath -> IO [FilePath]
-dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) topdir
+dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) True topdir
 
 {- Skips directories whose basenames match the skipdir. -}
-dirContentsRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
-dirContentsRecursiveSkipping skipdir topdir = go [topdir]
+dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
+dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
   where
   	go [] = return []
 	go (dir:dirs)
@@ -56,10 +60,18 @@ dirContentsRecursiveSkipping skipdir topdir = go [topdir]
 	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
-				)			
+			let skip = collect (entry:files) dirs' entries
+			let recurse = collect files (entry:dirs') entries
+			ms <- catchMaybeIO $ getSymbolicLinkStatus entry
+			case ms of
+				(Just s) 
+					| isDirectory s -> recurse
+					| isSymbolicLink s && followsubdirsymlinks ->
+						ifM (doesDirectoryExist entry)
+							( recurse
+							, skip
+							)
+				_ -> skip
 
 {- Moves one filename to another.
  - First tries a rename, but falls back to moving across devices if needed. -}
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index f33ad44..7ad9b12 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -25,7 +25,7 @@ type MeterUpdate = (BytesProcessed -> IO ())
 
 {- Total number of bytes processed so far. -}
 newtype BytesProcessed = BytesProcessed Integer
-	deriving (Eq, Ord)
+	deriving (Eq, Ord, Show)
 
 class AsBytesProcessed a where
 	toBytesProcessed :: a -> BytesProcessed
diff --git a/Utility/Path.hs b/Utility/Path.hs
index b6214b2..44ac72f 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -242,13 +242,13 @@ fileNameLengthLimit dir = do
  - 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.
+ - All spaces and punctuation and other wacky stuff 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 == '/' = '_'
+		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
 		| otherwise = c
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 03cbe95..1945e4b 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -26,12 +26,12 @@ module Utility.Process (
 	withHandle,
 	withBothHandles,
 	withQuietOutput,
-	withNullHandle,
 	createProcess,
 	startInteractiveProcess,
 	stdinHandle,
 	stdoutHandle,
 	stderrHandle,
+	devNull,
 ) where
 
 import qualified System.Process
@@ -280,20 +280,18 @@ withQuietOutput
 	:: CreateProcessRunner
 	-> CreateProcess
 	-> IO ()
-withQuietOutput creator p = withNullHandle $ \nullh -> do
+withQuietOutput creator p = withFile devNull WriteMode $ \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
+devNull :: FilePath
 #ifndef mingw32_HOST_OS
-	devnull = "/dev/null"
+devNull = "/dev/null"
 #else
-	devnull = "NUL"
+devNull = "NUL"
 #endif
 
 {- Extract a desired handle from createProcess's tuple.
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index 186cd12..891ce50 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Utility.Tmp where
 
 import Control.Exception (bracket)
@@ -61,8 +63,17 @@ withTmpDir template a = do
 withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a
 withTmpDirIn tmpdir template = bracket create remove
   where
-	remove d = whenM (doesDirectoryExist d) $
+	remove d = whenM (doesDirectoryExist d) $ do
+#if mingw32_HOST_OS
+		-- Windows will often refuse to delete a file
+		-- after a process has just written to it and exited.
+		-- Because it's crap, presumably. So, ignore failure
+		-- to delete the temp directory.
+		_ <- tryIO $ removeDirectoryRecursive d
+		return ()
+#else
 		removeDirectoryRecursive d
+#endif
 	create = do
 		createDirectoryIfMissing True tmpdir
 		makenewdir (tmpdir </> template) (0 :: Int)