propellor spin

debian/changelog

@@ -1,9 +1,12 @@
-propellor (2.3.1) UNRELEASED; urgency=medium
+propellor (2.4.0) UNRELEASED; urgency=medium
 
   * Git.bareRepo: Fix bug in calls to userScriptProperty.
     Thanks, Jelmer Vernooij.
   * Removed Obnam.latestVersion which was only needed for Debian wheezy
     backport.
+  * Merged Utility changes from git-annex.
+  * Switched from MonadCatchIO-transformers to the newer transformers and
+    exceptions libraries.
 
  -- Joey Hess <id@joeyh.name>  Wed, 22 Apr 2015 20:59:59 -0400
 

debian/control

@@ -15,7 +15,8 @@ Build-Depends:
 	libghc-network-dev,
 	libghc-quickcheck2-dev,
 	libghc-mtl-dev,
-	libghc-monadcatchio-transformers-dev,
+	libghc-transformers-dev,
+	libghc-exceptions-dev,
 Maintainer: Gergely Nagy <algernon@madhouse-project.org>
 Standards-Version: 3.9.6
 Vcs-Git: git://git.joeyh.name/propellor
@@ -36,7 +37,8 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
 	libghc-network-dev,
 	libghc-quickcheck2-dev,
 	libghc-mtl-dev,
-	libghc-monadcatchio-transformers-dev,
+	libghc-transformers-dev,
+	libghc-exceptions-dev,
 	git,
 Description: property-based host configuration management in haskell
  Propellor enures that the system it's run in satisfies a list of

propellor.cabal

@@ -37,8 +37,8 @@ Executable propellor
   Hs-Source-Dirs:  src
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
-   containers, network, async, time, QuickCheck, mtl,
+   containers, network, async, time, QuickCheck, mtl, transformers,
-   MonadCatchIO-transformers
+   exceptions
 
   if (! os(windows))
     Build-Depends: unix
@@ -49,8 +49,8 @@ Executable propellor-config
   Hs-Source-Dirs:  src
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
-   containers, network, async, time, QuickCheck, mtl,
+   containers, network, async, time, QuickCheck, mtl, transformers,
-   MonadCatchIO-transformers
+   exceptions
 
   if (! os(windows))
     Build-Depends: unix
@@ -60,8 +60,8 @@ Library
   Hs-Source-Dirs:  src
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
-   containers, network, async, time, QuickCheck, mtl,
+   containers, network, async, time, QuickCheck, mtl, transformers,
-   MonadCatchIO-transformers
+   exceptions
 
   if (! os(windows))
     Build-Depends: unix

src/Propellor/Engine.hs

@@ -17,7 +17,6 @@ import Data.Monoid
 import Control.Applicative
 import System.Console.ANSI
 import "mtl" Control.Monad.RWS.Strict
-import Control.Exception (bracket)
 import System.PosixCompat
 import System.Posix.IO
 import System.FilePath

src/Propellor/Exception.hs

@@ -2,11 +2,11 @@
 
 module Propellor.Exception where
 
-import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
-import Control.Exception
-
 import Propellor.Types
 import Propellor.Message
+import Utility.Exception
+
+import Control.Exception (IOException)
 
 -- | Catches IO exceptions and returns FailedChange.
 catchPropellor :: Propellor Result -> Propellor Result
@@ -15,4 +15,4 @@ catchPropellor a = either err return =<< tryPropellor a
 	err e =  warningMessage (show e) >> return FailedChange
 
 tryPropellor :: Propellor a -> Propellor (Either IOException a)
-tryPropellor = M.try
+tryPropellor = try

src/Propellor/Property/Debootstrap.hs

@@ -20,7 +20,6 @@ import Utility.FileMode
 
 import Data.List
 import Data.Char
-import Control.Exception
 import System.Posix.Directory
 import System.Posix.Files
 

src/Propellor/Spin.hs

@@ -12,7 +12,6 @@ import System.PosixCompat
 import System.Posix.IO
 import System.Posix.Directory
 import Control.Concurrent.Async
-import Control.Exception (bracket)
 import qualified Data.ByteString as B
 import qualified Data.Set as S
 import qualified Network.BSD as BSD
@@ -168,7 +167,7 @@ updateServer
 	-> CreateProcess
 	-> IO ()
 updateServer target relay hst connect haveprecompiled =
-	withBothHandles createProcessSuccess connect go
+	withIOHandles createProcessSuccess connect go
   where
 	hn = fromMaybe target relay
 	relaying = relay == Just target

src/Propellor/Types.hs

@@ -40,7 +40,7 @@ module Propellor.Types
 import Data.Monoid
 import Control.Applicative
 import "mtl" Control.Monad.RWS.Strict
-import "MonadCatchIO-transformers" Control.Monad.CatchIO
+import Control.Monad.Catch
 import qualified Data.Set as S
 import qualified Data.Map as M
 
@@ -73,7 +73,9 @@ newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
 		, MonadReader Host
 		, MonadWriter [EndAction]
 		, MonadIO
-		, MonadCatchIO
+		, MonadCatch
+		, MonadThrow
+		, MonadMask
 		)
 
 instance Monoid (Propellor Result) where

src/Utility/Applicative.hs

@@ -1,6 +1,6 @@
 {- applicative stuff
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}

src/Utility/Data.hs

@@ -1,6 +1,6 @@
 {- utilities for simple data types
  -
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}

src/Utility/DataUnits.hs

@@ -42,6 +42,7 @@ module Utility.DataUnits (
 	bandwidthUnits,
 	oldSchoolUnits,
 	Unit(..),
+	ByteSize,
 
 	roughSize,
 	compareSizes,

src/Utility/Directory.hs

@@ -1,4 +1,4 @@
-{- directory manipulation
+{- directory traversal and manipulation
  -
  - Copyright 2011-2014 Joey Hess <id@joeyh.name>
  -
@@ -11,12 +11,19 @@ module Utility.Directory where
 
 import System.IO.Error
 import System.Directory
-import Control.Exception (throw)
 import Control.Monad
 import Control.Monad.IfElse
 import System.FilePath
 import Control.Applicative
+import Control.Concurrent
 import System.IO.Unsafe (unsafeInterleaveIO)
+import Data.Maybe
+
+#ifdef mingw32_HOST_OS
+import qualified System.Win32 as Win32
+#else
+import qualified System.Posix as Posix
+#endif
 
 import Utility.PosixFiles
 import Utility.SafeCommand
@@ -49,7 +56,7 @@ dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
 dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
 dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
   where
-  	go [] = return []
+	go [] = return []
 	go (dir:dirs)
 		| skipdir (takeFileName dir) = go dirs
 		| otherwise = unsafeInterleaveIO $ do
@@ -80,7 +87,7 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
 dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
 dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
   where
-  	go c [] = return c
+	go c [] = return c
 	go c (dir:dirs)
 		| skipdir (takeFileName dir) = go c dirs
 		| otherwise = unsafeInterleaveIO $ do
@@ -104,9 +111,9 @@ moveFile src dest = tryIO (rename src dest) >>= onrename
 			-- But, mv will move into a directory if
 			-- dest is one, which is not desired.
 			whenM (isdir dest) rethrow
-			viaTmp mv dest undefined
+			viaTmp mv dest ""
 	  where
-		rethrow = throw e
+		rethrow = throwM e
 		mv tmp _ = do
 			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
 			unless ok $ do
@@ -133,3 +140,90 @@ nukeFile file = void $ tryWhenExists go
 #else
 	go = removeFile file
 #endif
+
+#ifndef mingw32_HOST_OS
+data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
+#else
+data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())
+#endif
+
+type IsOpen = MVar () -- full when the handle is open
+
+openDirectory :: FilePath -> IO DirectoryHandle
+openDirectory path = do
+#ifndef mingw32_HOST_OS
+	dirp <- Posix.openDirStream path
+	isopen <- newMVar ()
+	return (DirectoryHandle isopen dirp)
+#else
+	(h, fdat) <- Win32.findFirstFile (path </> "*")
+	-- Indicate that the fdat contains a filename that readDirectory
+	-- has not yet returned, by making the MVar be full.
+	-- (There's always at least a "." entry.)
+	alreadyhave <- newMVar ()
+	isopen <- newMVar ()
+	return (DirectoryHandle isopen h fdat alreadyhave)
+#endif
+
+closeDirectory :: DirectoryHandle -> IO ()
+#ifndef mingw32_HOST_OS
+closeDirectory (DirectoryHandle isopen dirp) =
+	whenOpen isopen $
+		Posix.closeDirStream dirp
+#else
+closeDirectory (DirectoryHandle isopen h _ alreadyhave) =
+	whenOpen isopen $ do
+		_ <- tryTakeMVar alreadyhave
+		Win32.findClose h
+#endif
+  where
+	whenOpen :: IsOpen -> IO () -> IO ()
+	whenOpen mv f = do
+		v <- tryTakeMVar mv
+		when (isJust v) f
+
+{- |Reads the next entry from the handle. Once the end of the directory
+is reached, returns Nothing and automatically closes the handle.
+-}
+readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
+#ifndef mingw32_HOST_OS
+readDirectory hdl@(DirectoryHandle _ dirp) = do
+	e <- Posix.readDirStream dirp
+	if null e
+		then do
+			closeDirectory hdl
+			return Nothing
+		else return (Just e)
+#else
+readDirectory hdl@(DirectoryHandle _ h fdat mv) = do
+	-- If the MVar is full, then the filename in fdat has
+	-- not yet been returned. Otherwise, need to find the next
+	-- file.
+	r <- tryTakeMVar mv
+	case r of
+		Just () -> getfn
+		Nothing -> do
+			more <- Win32.findNextFile h fdat
+			if more
+				then getfn
+				else do
+					closeDirectory hdl
+					return Nothing
+  where
+	getfn = do
+		filename <- Win32.getFindDataFileName fdat
+		return (Just filename)
+#endif
+
+-- True only when directory exists and contains nothing.
+-- Throws exception if directory does not exist.
+isDirectoryEmpty :: FilePath -> IO Bool
+isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
+  where
+	check h = do
+		v <- readDirectory h
+		case v of
+			Nothing -> return True
+			Just f
+				| not (dirCruft f) -> return False
+				| otherwise -> check h

src/Utility/Env.hs

@@ -1,6 +1,6 @@
 {- portable environment variables
  -
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}

src/Utility/Exception.hs

@@ -1,59 +1,88 @@
 {- Simple IO exception handling (and some more)
  -
- - Copyright 2011-2012 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
 
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Utility.Exception where
+module Utility.Exception (
+	module X,
+	catchBoolIO,
+	catchMaybeIO,
+	catchDefaultIO,
+	catchMsgIO,
+	catchIO,
+	tryIO,
+	bracketIO,
+	catchNonAsync,
+	tryNonAsync,
+	tryWhenExists,
+) where
 
-import Control.Exception
+import Control.Monad.Catch as X hiding (Handler)
-import qualified Control.Exception as E
+import qualified Control.Monad.Catch as M
-import Control.Applicative
+import Control.Exception (IOException, AsyncException)
 import Control.Monad
+import Control.Monad.IO.Class (liftIO, MonadIO)
 import System.IO.Error (isDoesNotExistError)
 import Utility.Data
 
 {- Catches IO errors and returns a Bool -}
-catchBoolIO :: IO Bool -> IO Bool
+catchBoolIO :: MonadCatch m => m Bool -> m Bool
 catchBoolIO = catchDefaultIO False
 
 {- Catches IO errors and returns a Maybe -}
-catchMaybeIO :: IO a -> IO (Maybe a)
+catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
-catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a
+catchMaybeIO a = do
+	catchDefaultIO Nothing $ do
+		v <- a
+		return (Just v)
 
 {- Catches IO errors and returns a default value. -}
-catchDefaultIO :: a -> IO a -> IO a
+catchDefaultIO :: MonadCatch m => a -> m a -> m 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 :: MonadCatch m => m a -> m (Either String a)
-catchMsgIO a = either (Left . show) Right <$> tryIO a
+catchMsgIO a = do
+	v <- tryIO a
+	return $ either (Left . show) Right v
 
 {- catch specialized for IO errors only -}
-catchIO :: IO a -> (IOException -> IO a) -> IO a
+catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a
-catchIO = E.catch
+catchIO = M.catch
 
 {- try specialized for IO errors only -}
-tryIO :: IO a -> IO (Either IOException a)
+tryIO :: MonadCatch m => m a -> m (Either IOException a)
-tryIO = try
+tryIO = M.try
+
+{- bracket with setup and cleanup actions lifted to IO.
+ -
+ - Note that unlike catchIO and tryIO, this catches all exceptions. -}
+bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a
+bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)
 
 {- 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 :: MonadCatch m => m a -> (SomeException -> m a) -> m a
 catchNonAsync a onerr = a `catches`
-	[ Handler (\ (e :: AsyncException) -> throw e)
+	[ M.Handler (\ (e :: AsyncException) -> throwM e)
-	, Handler (\ (e :: SomeException) -> onerr e)
+	, M.Handler (\ (e :: SomeException) -> onerr e)
 	]
 
-tryNonAsync :: IO a -> IO (Either SomeException a)
+tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)
-tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)
+tryNonAsync a = go `catchNonAsync` (return . Left)
+  where
+	go = do
+		v <- a
+		return (Right v)
 
 {- Catches only DoesNotExist exceptions, and lets all others through. -}
-tryWhenExists :: IO a -> IO (Maybe a)
+tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
-tryWhenExists a = eitherToMaybe <$>
+tryWhenExists a = do
-	tryJust (guard . isDoesNotExistError) a
+	v <- tryJust (guard . isDoesNotExistError) a
+	return (eitherToMaybe v)

src/Utility/FileMode.hs

@@ -11,7 +11,6 @@ module Utility.FileMode where
 
 import System.IO
 import Control.Monad
-import Control.Exception (bracket)
 import System.PosixCompat.Types
 import Utility.PosixFiles
 #ifndef mingw32_HOST_OS
@@ -125,7 +124,7 @@ withUmask _ a = a
 #endif
 
 combineModes :: [FileMode] -> FileMode
-combineModes [] = undefined
+combineModes [] = 0
 combineModes [m] = m
 combineModes (m:ms) = foldl unionFileModes m ms
 
@@ -152,7 +151,11 @@ setSticky f = modifyFileMode f $ addModes [stickyMode]
  - as writeFile.
  -}
 writeFileProtected :: FilePath -> String -> IO ()
-writeFileProtected file content = withUmask 0o0077 $
+writeFileProtected file content = writeFileProtected' file 
+	(\h -> hPutStr h content)
+
+writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()
+writeFileProtected' file writer = withUmask 0o0077 $
 	withFile file WriteMode $ \h -> do
 		void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
-		hPutStr h content
+		writer h

src/Utility/FileSystemEncoding.hs

@@ -1,6 +1,6 @@
 {- GHC File system encoding handling.
  -
- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -14,6 +14,8 @@ module Utility.FileSystemEncoding (
 	decodeBS,
 	decodeW8,
 	encodeW8,
+	encodeW8NUL,
+	decodeW8NUL,
 	truncateFilePath,
 ) where
 
@@ -25,6 +27,7 @@ import System.IO.Unsafe
 import qualified Data.Hash.MD5 as MD5
 import Data.Word
 import Data.Bits.Utils
+import Data.List.Utils
 import qualified Data.ByteString.Lazy as L
 #ifdef mingw32_HOST_OS
 import qualified Data.ByteString.Lazy.UTF8 as L8
@@ -89,6 +92,9 @@ decodeBS = L8.toString
  - 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.
+ -
+ - Note that the encoding stops at any NUL in the input. FilePaths
+ - do not normally contain embedded NUL, but Haskell Strings may.
  -}
 {-# NOINLINE encodeW8 #-}
 encodeW8 :: [Word8] -> FilePath
@@ -101,6 +107,17 @@ encodeW8 w8 = unsafePerformIO $ do
 decodeW8 :: FilePath -> [Word8]
 decodeW8 = s2w8 . _encodeFilePath
 
+{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -}
+encodeW8NUL :: [Word8] -> FilePath
+encodeW8NUL = join nul . map encodeW8 . split (s2w8 nul)
+  where
+	nul = ['\NUL']
+
+decodeW8NUL :: FilePath -> [Word8]
+decodeW8NUL = join (s2w8 nul) . map decodeW8 . split nul
+  where
+	nul = ['\NUL']
+
 {- Truncates a FilePath to the given number of bytes (or less),
  - as represented on disk.
  -

src/Utility/LinuxMkLibs.hs

@@ -1,6 +1,6 @@
 {- Linux library copier and binary shimmer
  -
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -29,14 +29,14 @@ installLib installfile top lib = ifM (doesFileExist lib)
 	( do
 		installfile top lib
 		checksymlink lib
-		return $ Just $ takeDirectory lib
+		return $ Just $ parentDir lib
 	, return Nothing
 	)
   where
 	checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
 		l <- readSymbolicLink (inTop top f)
-		let absl = absPathFrom (takeDirectory f) l
+		let absl = absPathFrom (parentDir f) l
-		let target = relPathDirToFile (takeDirectory f) absl
+		target <- relPathDirToFile (takeDirectory f) absl
 		installfile top absl
 		nukeFile (top ++ f)
 		createSymbolicLink target (inTop top f)

src/Utility/Misc.hs

@@ -1,6 +1,6 @@
 {- misc utility functions
  -
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2011 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}

src/Utility/Monad.hs

@@ -1,6 +1,6 @@
 {- monadic stuff
  -
- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}

src/Utility/Path.hs

@@ -1,6 +1,6 @@
 {- path manipulation
  -
- - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -66,7 +66,7 @@ absPathFrom :: FilePath -> FilePath -> FilePath
 absPathFrom dir path = simplifyPath (combine dir path)
 
 {- On Windows, this converts the paths to unix-style, in order to run
- - MissingH's absNormPath on them. Resulting path will use / separators. -}
+ - MissingH's absNormPath on them. -}
 absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
 #ifndef mingw32_HOST_OS
 absNormPathUnix dir path = MissingH.absNormPath dir path
@@ -77,11 +77,15 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos
 	todos = replace "/" "\\"
 #endif
 
+{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
+parentDir :: FilePath -> FilePath
+parentDir = takeDirectory . dropTrailingPathSeparator
+
 {- Just the parent directory of a path, or Nothing if the path has no
- - parent (ie for "/") -}
+- parent (ie for "/" or ".") -}
-parentDir :: FilePath -> Maybe FilePath
+upFrom :: FilePath -> Maybe FilePath
-parentDir dir
+upFrom dir
-	| null dirs = Nothing
+	| length dirs < 2 = Nothing
 	| otherwise = Just $ joinDrive drive (join s $ init dirs)
   where
 	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
@@ -89,13 +93,13 @@ parentDir dir
 	dirs = filter (not . null) $ split s path
 	s = [pathSeparator]
 
-prop_parentDir_basics :: FilePath -> Bool
+prop_upFrom_basics :: FilePath -> Bool
-prop_parentDir_basics dir
+prop_upFrom_basics dir
 	| null dir = True
-	| dir == "/" = parentDir dir == Nothing
+	| dir == "/" = p == Nothing
 	| otherwise = p /= Just dir
   where
-	p = parentDir dir
+	p = upFrom 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
@@ -124,14 +128,25 @@ absPath file = do
  -    relPathCwdToFile "/tmp/foo/bar" == "" 
  -}
 relPathCwdToFile :: FilePath -> IO FilePath
-relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
+relPathCwdToFile f = do
+	c <- getCurrentDirectory
+	relPathDirToFile c f
 
-{- Constructs a relative path from a directory to a file.
+{- Constructs a relative path from a directory to a file. -}
+relPathDirToFile :: FilePath -> FilePath -> IO FilePath
+relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
+
+{- This requires the first path to be absolute, and the
+ - second path cannot contain ../ or ./
  -
- - Both must be absolute, and cannot contain .. etc. (eg use absPath first).
+ - On Windows, if the paths are on different drives,
+ - a relative path is not possible and the path is simply
+ - returned as-is.
  -}
-relPathDirToFile :: FilePath -> FilePath -> FilePath
+relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
-relPathDirToFile from to = join s $ dotdots ++ uncommon
+relPathDirToFileAbs from to
+	| takeDrive from /= takeDrive to = to
+	| otherwise = join s $ dotdots ++ uncommon
   where
 	s = [pathSeparator]
 	pfrom = split s from
@@ -144,10 +159,11 @@ relPathDirToFile from to = join s $ dotdots ++ uncommon
 
 prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
 prop_relPathDirToFile_basics from to
+	| null from || null to = True
 	| from == to = null r
 	| otherwise = not (null r)
   where
-	r = relPathDirToFile from to 
+	r = relPathDirToFileAbs from to 
 
 prop_relPathDirToFile_regressionTest :: Bool
 prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
@@ -156,22 +172,31 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
 	 - 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"])
+		relPathDirToFileAbs (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
+ - which may be arbitrarily reordered, generates a list of lists, where
- - original paths. When the original path is a directory, any items
+ - each sublist corresponds to one of the original paths.
- - in the expanded list that are contained in that directory will appear in
+ -
- - its segment.
+ - When the original path is a directory, any items in the expanded list
+ - that are contained in that directory will appear in its segment.
+ -
+ - The order of the original list of paths is attempted to be preserved in
+ - the order of the returned segments. However, doing so has a O^NM
+ - growth factor. So, if the original list has more than 100 paths on it,
+ - we stop preserving ordering at that point. Presumably a user passing
+ - that many paths in doesn't care too much about order of the later ones.
  -}
 segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
 segmentPaths [] new = [new]
 segmentPaths [_] new = [new] -- optimisation
-segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest
+segmentPaths (l:ls) new = found : segmentPaths ls rest
   where
-	(found, rest)=partition (l `dirContains`) new
+	(found, rest) = if length ls < 100
+		then partition (l `dirContains`) new
+		else break (\p -> not (l `dirContains` p)) 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
@@ -185,7 +210,7 @@ relHome :: FilePath -> IO String
 relHome path = do
 	home <- myHomeDir
 	return $ if dirContains home path
-		then "~/" ++ relPathDirToFile home path
+		then "~/" ++ relPathDirToFileAbs home path
 		else path
 
 {- Checks if a command is available in PATH.

src/Utility/PosixFiles.hs

@@ -2,7 +2,7 @@
  -
  - This is like System.PosixCompat.Files, except with a fixed rename.
  -
- - Copyright 2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2014 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}

src/Utility/Process.hs

@@ -25,14 +25,16 @@ module Utility.Process (
 	processTranscript,
 	processTranscript',
 	withHandle,
-	withBothHandles,
+	withIOHandles,
+	withOEHandles,
 	withQuietOutput,
+	feedWithQuietOutput,
 	createProcess,
 	startInteractiveProcess,
 	stdinHandle,
 	stdoutHandle,
 	stderrHandle,
-	bothHandles,
+	ioHandles,
 	processHandle,
 	devNull,
 ) where
@@ -255,12 +257,12 @@ withHandle h creator p a = creator p' $ a . select
 			(stderrHandle, base { std_err = CreatePipe })
 
 {- Like withHandle, but passes (stdin, stdout) handles to the action. -}
-withBothHandles
+withIOHandles
 	:: CreateProcessRunner
 	-> CreateProcess
 	-> ((Handle, Handle) -> IO a)
 	-> IO a
-withBothHandles creator p a = creator p' $ a . bothHandles
+withIOHandles creator p a = creator p' $ a . ioHandles
   where
 	p' = p
 		{ std_in = CreatePipe
@@ -268,6 +270,20 @@ withBothHandles creator p a = creator p' $ a . bothHandles
 		, std_err = Inherit
 		}
 
+{- Like withHandle, but passes (stdout, stderr) handles to the action. -}
+withOEHandles
+	:: CreateProcessRunner
+	-> CreateProcess
+	-> ((Handle, Handle) -> IO a)
+	-> IO a
+withOEHandles creator p a = creator p' $ a . oeHandles
+  where
+	p' = p
+		{ std_in = Inherit
+		, std_out = CreatePipe
+		, std_err = CreatePipe
+		}
+
 {- Forces the CreateProcessRunner to run quietly;
  - both stdout and stderr are discarded. -}
 withQuietOutput
@@ -281,6 +297,21 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
 		}
 	creator p' $ const $ return ()
 
+{- Stdout and stderr are discarded, while the process is fed stdin
+ - from the handle. -}
+feedWithQuietOutput
+	:: CreateProcessRunner
+	-> CreateProcess
+	-> (Handle -> IO a)
+	-> IO a
+feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do
+	let p' = p
+		{ std_in = CreatePipe
+		, std_out = UseHandle nullh
+		, std_err = UseHandle nullh
+		}
+	creator p' $ a . stdinHandle
+
 devNull :: FilePath
 #ifndef mingw32_HOST_OS
 devNull = "/dev/null"
@@ -303,9 +334,12 @@ stdoutHandle _ = error "expected stdoutHandle"
 stderrHandle :: HandleExtractor
 stderrHandle (_, _, Just h, _) = h
 stderrHandle _ = error "expected stderrHandle"
-bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
+ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
-bothHandles (Just hin, Just hout, _, _) = (hin, hout)
+ioHandles (Just hin, Just hout, _, _) = (hin, hout)
-bothHandles _ = error "expected bothHandles"
+ioHandles _ = error "expected ioHandles"
+oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
+oeHandles (_, Just hout, Just herr, _) = (hout, herr)
+oeHandles _ = error "expected oeHandles"
 
 processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
 processHandle (_, _, _, pid) = pid

src/Utility/QuickCheck.hs

@@ -1,6 +1,6 @@
 {- QuickCheck with additional instances
  -
- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}

src/Utility/SafeCommand.hs

@@ -1,6 +1,6 @@
 {- safely running shell commands
  -
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -101,19 +101,26 @@ 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
+{- Segments a list of filenames into groups that are all below the maximum
- - command-line length limit. Does not preserve order. -}
+ - command-line length limit. -}
-segmentXargs :: [FilePath] -> [[FilePath]]
+segmentXargsOrdered :: [FilePath] -> [[FilePath]]
-segmentXargs l = go l [] 0 []
+segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered
+
+{- Not preserving data is a little faster, and streams better when
+ - there are a great many filesnames. -}
+segmentXargsUnordered :: [FilePath] -> [[FilePath]]
+segmentXargsUnordered l = go l [] 0 []
   where
-	go [] c _ r = c:r
+	go [] c _ r = (c:r)
 	go (f:fs) c accumlen r
-		| len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)
+		| newlen > maxlen && len < 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;
+	{- 10k of filenames per command, well under 100k limit
-	 - allows room for other parameters etc. -}
+	 - of Linux (and OSX has a similar limit);
+	 - allows room for other parameters etc. Also allows for
+	 - eg, multibyte characters. -}
 	maxlen = 10240

src/Utility/Scheduled.hs

@@ -1,6 +1,6 @@
 {- scheduled activities
  - 
- - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
+ - Copyright 2013-2014 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}

src/Utility/ThreadScheduler.hs

@@ -1,6 +1,6 @@
 {- thread scheduling
  -
- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
  - Copyright 2011 Bas van Dijk & Roel van Dijk
  -
  - License: BSD-2-clause

src/Utility/Tmp.hs

@@ -9,11 +9,11 @@
 
 module Utility.Tmp where
 
-import Control.Exception (bracket)
 import System.IO
 import System.Directory
 import Control.Monad.IfElse
 import System.FilePath
+import Control.Monad.IO.Class
 
 import Utility.Exception
 import Utility.FileSystemEncoding
@@ -24,45 +24,52 @@ 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 :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()
-viaTmp a file content = do
+viaTmp a file content = bracketIO setup cleanup use
-	let (dir, base) = splitFileName file
+  where
-	createDirectoryIfMissing True dir
+	(dir, base) = splitFileName file
-	(tmpfile, handle) <- openTempFile dir (base ++ ".tmp")
+	template = base ++ ".tmp"
-	hClose handle
+	setup = do
-	a tmpfile content
+		createDirectoryIfMissing True dir
-	rename tmpfile file
+		openTempFile dir template
+	cleanup (tmpfile, h) = do
+		_ <- tryIO $ hClose h
+		tryIO $ removeFile tmpfile
+	use (tmpfile, h) = do
+		liftIO $ hClose h
+		a tmpfile content
+		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. -}
-withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a
+withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a
 withTmpFile template a = do
-	tmpdir <- catchDefaultIO "." getTemporaryDirectory
+	tmpdir <- liftIO $ 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 :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a
 withTmpFileIn tmpdir template a = bracket create remove use
   where
-	create = openTempFile tmpdir template
+	create = liftIO $ openTempFile tmpdir template
-	remove (name, handle) = do
+	remove (name, h) = liftIO $ do
-		hClose handle
+		hClose h
 		catchBoolIO (removeFile name >> return True)
-	use (name, handle) = a name handle
+	use (name, h) = a name h
 
 {- 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 :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
-withTmpDirIn tmpdir template = bracket create remove
+withTmpDirIn tmpdir template = bracketIO create remove
   where
 	remove d = whenM (doesDirectoryExist d) $ do
 #if mingw32_HOST_OS

src/Utility/UserInfo.hs

@@ -1,6 +1,6 @@
 {- user info
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}