summaryrefslogtreecommitdiff
path: root/src/Utility
diff options
context:
space:
mode:
authorJoey Hess2015-04-29 14:26:13 -0400
committerJoey Hess2015-04-29 14:26:13 -0400
commit681e4dbbcb880e8e2526519fc58d4f2994a41577 (patch)
tree58f0951f6fc4fc7c534b7c293592386b7575164a /src/Utility
parent960745b95e96e3d276e275554584c9bd13565f5b (diff)
propellor spin
Diffstat (limited to 'src/Utility')
-rw-r--r--src/Utility/Applicative.hs2
-rw-r--r--src/Utility/Data.hs2
-rw-r--r--src/Utility/DataUnits.hs1
-rw-r--r--src/Utility/Directory.hs106
-rw-r--r--src/Utility/Env.hs2
-rw-r--r--src/Utility/Exception.hs75
-rw-r--r--src/Utility/FileMode.hs11
-rw-r--r--src/Utility/FileSystemEncoding.hs19
-rw-r--r--src/Utility/LinuxMkLibs.hs8
-rw-r--r--src/Utility/Misc.hs2
-rw-r--r--src/Utility/Monad.hs2
-rw-r--r--src/Utility/Path.hs73
-rw-r--r--src/Utility/PosixFiles.hs2
-rw-r--r--src/Utility/Process.hs48
-rw-r--r--src/Utility/QuickCheck.hs2
-rw-r--r--src/Utility/SafeCommand.hs25
-rw-r--r--src/Utility/Scheduled.hs2
-rw-r--r--src/Utility/ThreadScheduler.hs2
-rw-r--r--src/Utility/Tmp.hs47
-rw-r--r--src/Utility/UserInfo.hs2
20 files changed, 325 insertions, 108 deletions
diff --git a/src/Utility/Applicative.hs b/src/Utility/Applicative.hs
index fd8944b2..fce3c048 100644
--- a/src/Utility/Applicative.hs
+++ b/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
-}
diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs
index 2df12b36..5ecd218f 100644
--- a/src/Utility/Data.hs
+++ b/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
-}
diff --git a/src/Utility/DataUnits.hs b/src/Utility/DataUnits.hs
index 2ece1430..6e40932e 100644
--- a/src/Utility/DataUnits.hs
+++ b/src/Utility/DataUnits.hs
@@ -42,6 +42,7 @@ module Utility.DataUnits (
bandwidthUnits,
oldSchoolUnits,
Unit(..),
+ ByteSize,
roughSize,
compareSizes,
diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs
index 6b50016f..2e037fdd 100644
--- a/src/Utility/Directory.hs
+++ b/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
diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs
index ff6644fb..fdf06d80 100644
--- a/src/Utility/Env.hs
+++ b/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
-}
diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs
index c6510dbc..ab47ae95 100644
--- a/src/Utility/Exception.hs
+++ b/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 qualified Control.Exception as E
-import Control.Applicative
+import Control.Monad.Catch as X hiding (Handler)
+import qualified Control.Monad.Catch as M
+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 a = catchDefaultIO Nothing $ Just <$> a
+catchMaybeIO :: MonadCatch m => m a -> m (Maybe 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 a = either (Left . show) Right <$> tryIO a
+catchMsgIO :: MonadCatch m => m a -> m (Either String 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 = E.catch
+catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a
+catchIO = M.catch
{- try specialized for IO errors only -}
-tryIO :: IO a -> IO (Either IOException a)
-tryIO = try
+tryIO :: MonadCatch m => m a -> m (Either IOException a)
+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)
- , Handler (\ (e :: SomeException) -> onerr e)
+ [ M.Handler (\ (e :: AsyncException) -> throwM e)
+ , M.Handler (\ (e :: SomeException) -> onerr e)
]
-tryNonAsync :: IO a -> IO (Either SomeException a)
-tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)
+tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)
+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 a = eitherToMaybe <$>
- tryJust (guard . isDoesNotExistError) a
+tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
+tryWhenExists a = do
+ v <- tryJust (guard . isDoesNotExistError) a
+ return (eitherToMaybe v)
diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs
index 82568f6e..201b8451 100644
--- a/src/Utility/FileMode.hs
+++ b/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
diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs
index fa4b39aa..139b74fe 100644
--- a/src/Utility/FileSystemEncoding.hs
+++ b/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.
-
diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs
index 6074ba26..db64d123 100644
--- a/src/Utility/LinuxMkLibs.hs
+++ b/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 target = relPathDirToFile (takeDirectory f) absl
+ let absl = absPathFrom (parentDir f) l
+ target <- relPathDirToFile (takeDirectory f) absl
installfile top absl
nukeFile (top ++ f)
createSymbolicLink target (inTop top f)
diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs
index 949f41e7..e4eccac4 100644
--- a/src/Utility/Misc.hs
+++ b/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
-}
diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs
index eba3c428..878e0da6 100644
--- a/src/Utility/Monad.hs
+++ b/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
-}
diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs
index 7f034912..9f0737fe 100644
--- a/src/Utility/Path.hs
+++ b/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 "/") -}
-parentDir :: FilePath -> Maybe FilePath
-parentDir dir
- | null dirs = Nothing
+- parent (ie for "/" or ".") -}
+upFrom :: FilePath -> Maybe FilePath
+upFrom dir
+ | 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_parentDir_basics dir
+prop_upFrom_basics :: FilePath -> Bool
+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. -}
+relPathDirToFile :: FilePath -> FilePath -> IO FilePath
+relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
-{- Constructs a relative path from a directory to a file.
+{- 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
-relPathDirToFile from to = join s $ dotdots ++ uncommon
+relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
+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
- - 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.
+ - which may be arbitrarily reordered, 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.
+ -
+ - 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.
diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs
index 5abbb578..5a94ead0 100644
--- a/src/Utility/PosixFiles.hs
+++ b/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
-}
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index 8fefaa54..cbbe8a81 100644
--- a/src/Utility/Process.hs
+++ b/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)
-bothHandles (Just hin, Just hout, _, _) = (hin, hout)
-bothHandles _ = error "expected bothHandles"
+ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
+ioHandles (Just hin, Just hout, _, _) = (hin, hout)
+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
diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs
index a498ee61..54200d3f 100644
--- a/src/Utility/QuickCheck.hs
+++ b/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
-}
diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs
index 86e60db0..f44112b8 100644
--- a/src/Utility/SafeCommand.hs
+++ b/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
- - command-line length limit. Does not preserve order. -}
-segmentXargs :: [FilePath] -> [[FilePath]]
-segmentXargs l = go l [] 0 []
+{- Segments a list of filenames into groups that are all below the maximum
+ - command-line length limit. -}
+segmentXargsOrdered :: [FilePath] -> [[FilePath]]
+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;
- - allows room for other parameters etc. -}
+ {- 10k of filenames per command, well under 100k limit
+ - of Linux (and OSX has a similar limit);
+ - allows room for other parameters etc. Also allows for
+ - eg, multibyte characters. -}
maxlen = 10240
diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs
index 4fa3a29f..e077a1fe 100644
--- a/src/Utility/Scheduled.hs
+++ b/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
-}
diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs
index e6a81aeb..da05e996 100644
--- a/src/Utility/ThreadScheduler.hs
+++ b/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
diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs
index d0cae337..dc559813 100644
--- a/src/Utility/Tmp.hs
+++ b/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 a file content = do
- let (dir, base) = splitFileName file
- createDirectoryIfMissing True dir
- (tmpfile, handle) <- openTempFile dir (base ++ ".tmp")
- hClose handle
- a tmpfile content
- rename tmpfile file
+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"
+ setup = do
+ createDirectoryIfMissing True dir
+ 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
- remove (name, handle) = do
- hClose handle
+ create = liftIO $ openTempFile tmpdir template
+ remove (name, h) = liftIO $ do
+ 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 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/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs
index c82f0407..5bf8d5c0 100644
--- a/src/Utility/UserInfo.hs
+++ b/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
-}