Merge from git-annex.

6 files changed, 118 insertions, 55 deletions

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