diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/Applicative.hs | 2 | ||||
| -rw-r--r-- | Utility/Batch.hs | 2 | ||||
| -rw-r--r-- | Utility/CoProcess.hs | 2 | ||||
| -rw-r--r-- | Utility/Data.hs | 2 | ||||
| -rw-r--r-- | Utility/Directory.hs | 4 | ||||
| -rw-r--r-- | Utility/DottedVersion.hs | 2 | ||||
| -rw-r--r-- | Utility/Env.hs | 2 | ||||
| -rw-r--r-- | Utility/Exception.hs | 2 | ||||
| -rw-r--r-- | Utility/FileMode.hs | 12 | ||||
| -rw-r--r-- | Utility/FileSystemEncoding.hs | 19 | ||||
| -rw-r--r-- | Utility/Format.hs | 2 | ||||
| -rw-r--r-- | Utility/Metered.hs | 93 | ||||
| -rw-r--r-- | Utility/Misc.hs | 2 | ||||
| -rw-r--r-- | Utility/Monad.hs | 2 | ||||
| -rw-r--r-- | Utility/Path.hs | 73 | ||||
| -rw-r--r-- | Utility/PosixFiles.hs | 2 | ||||
| -rw-r--r-- | Utility/Process.hs | 48 | ||||
| -rw-r--r-- | Utility/QuickCheck.hs | 2 | ||||
| -rw-r--r-- | Utility/Rsync.hs | 10 | ||||
| -rw-r--r-- | Utility/SafeCommand.hs | 25 | ||||
| -rw-r--r-- | Utility/ThreadScheduler.hs | 2 | ||||
| -rw-r--r-- | Utility/Tmp.hs | 2 | ||||
| -rw-r--r-- | Utility/URI.hs | 2 | ||||
| -rw-r--r-- | Utility/UserInfo.hs | 2 |
24 files changed, 232 insertions, 84 deletions
diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs index fd8944b..fce3c04 100644 --- a/Utility/Applicative.hs +++ b/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/Utility/Batch.hs b/Utility/Batch.hs index ff81318..d96f9d3 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -1,6 +1,6 @@ {- Running a long or expensive batch operation niced. - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index 97826ec..9854b47 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -1,7 +1,7 @@ {- Interface for running a shell command as a coprocess, - sending it queries and getting back results. - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} diff --git a/Utility/Data.hs b/Utility/Data.hs index 2df12b3..5ecd218 100644 --- a/Utility/Data.hs +++ b/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/Utility/Directory.hs b/Utility/Directory.hs index e4e4b80..2e037fd 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,6 +1,6 @@ {- directory traversal and manipulation - - - Copyright 2011-2014 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -111,7 +111,7 @@ 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 = throwM e mv tmp _ = do diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs index 14aa16d..67e40ff 100644 --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -1,6 +1,6 @@ {- dotted versions, such as 1.0.1 - - - Copyright 2011-2014 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} diff --git a/Utility/Env.hs b/Utility/Env.hs index ff6644f..fdf06d8 100644 --- a/Utility/Env.hs +++ b/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/Utility/Exception.hs b/Utility/Exception.hs index ef3ab1d..ab47ae9 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2014 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 832250b..201b845 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,6 +1,6 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -124,7 +124,7 @@ withUmask _ a = a #endif combineModes :: [FileMode] -> FileMode -combineModes [] = undefined +combineModes [] = 0 combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms @@ -151,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/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index fa4b39a..139b74f 100644 --- a/Utility/FileSystemEncoding.hs +++ b/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/Utility/Format.hs b/Utility/Format.hs index 78620f9..0a6f6ce 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -1,6 +1,6 @@ {- Formatted string handling. - - - Copyright 2010, 2011 Joey Hess <joey@kitenet.net> + - Copyright 2010, 2011 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} diff --git a/Utility/Metered.hs b/Utility/Metered.hs index e4f3b44..c34e931 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,6 +1,6 @@ -{- Metered IO +{- Metered IO and actions - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2105 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -17,6 +17,8 @@ import System.IO.Unsafe import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types import Data.Int +import Data.Bits.Utils +import Control.Concurrent.Async {- An action that can be run repeatedly, updating it on the bytes processed. - @@ -142,10 +144,15 @@ defaultChunkSize :: Int defaultChunkSize = 32 * k - chunkOverhead where k = 1024 - chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific + chunkOverhead = 2 * sizeOf (1 :: Int) -- GHC specific + +data OutputHandler = OutputHandler + { quietMode :: Bool + , stderrHandler :: String -> IO () + } {- 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 + - Maybe the number of bytes done 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 @@ -154,21 +161,23 @@ defaultChunkSize = 32 * k - chunkOverhead 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 [] + - to update a meter. + -} +commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool +commandMeter progressparser oh meterupdate cmd params = + outputFilter cmd params Nothing + (feedprogress zeroBytesProcessed []) + handlestderr where - p = proc cmd (toCommand params) - feedprogress prev buf h = do - s <- hGetSomeString h 80 - if null s - then return True + b <- S.hGetSome h 80 + if S.null b + then return () else do - putStr s - hFlush stdout + unless (quietMode oh) $ do + S.hPut stdout b + hFlush stdout + let s = w82s (S.unpack b) let (mbytes, buf') = progressparser (buf++s) case mbytes of Nothing -> feedprogress prev buf' h @@ -176,3 +185,55 @@ commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $ when (bytes /= prev) $ meterupdate bytes feedprogress bytes buf' h + + handlestderr h = unlessM (hIsEOF h) $ do + stderrHandler oh =<< hGetLine h + handlestderr h + +{- Runs a command, that may display one or more progress meters on + - either stdout or stderr, and prevents the meters from being displayed. + - + - The other command output is handled as configured by the OutputHandler. + -} +demeterCommand :: OutputHandler -> FilePath -> [CommandParam] -> IO Bool +demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing + +demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +demeterCommandEnv oh cmd params environ = outputFilter cmd params environ + (\outh -> avoidProgress True outh stdouthandler) + (\errh -> avoidProgress True errh $ stderrHandler oh) + where + stdouthandler l = + unless (quietMode oh) $ + putStrLn l + +{- To suppress progress output, while displaying other messages, + - filter out lines that contain \r (typically used to reset to the + - beginning of the line when updating a progress display). + -} +avoidProgress :: Bool -> Handle -> (String -> IO ()) -> IO () +avoidProgress doavoid h emitter = unlessM (hIsEOF h) $ do + s <- hGetLine h + unless (doavoid && '\r' `elem` s) $ + emitter s + avoidProgress doavoid h emitter + +outputFilter + :: FilePath + -> [CommandParam] + -> Maybe [(String, String)] + -> (Handle -> IO ()) + -> (Handle -> IO ()) + -> IO Bool +outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do + (_, Just outh, Just errh, pid) <- createProcess p + { std_out = CreatePipe + , std_err = CreatePipe + } + void $ async $ tryIO (outfilter outh) >> hClose outh + void $ async $ tryIO (errfilter errh) >> hClose errh + ret <- checkSuccessProcess pid + return ret + where + p = (proc cmd (toCommand params)) + { env = environ } diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 949f41e..e4eccac 100644 --- a/Utility/Misc.hs +++ b/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/Utility/Monad.hs b/Utility/Monad.hs index eba3c42..878e0da 100644 --- a/Utility/Monad.hs +++ b/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/Utility/Path.hs b/Utility/Path.hs index 7f03491..9f0737f 100644 --- a/Utility/Path.hs +++ b/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/Utility/PosixFiles.hs b/Utility/PosixFiles.hs index 5abbb57..5a94ead 100644 --- a/Utility/PosixFiles.hs +++ b/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/Utility/Process.hs b/Utility/Process.hs index 8fefaa5..cbbe8a8 100644 --- a/Utility/Process.hs +++ b/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/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index a498ee6..54200d3 100644 --- a/Utility/QuickCheck.hs +++ b/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/Utility/Rsync.hs b/Utility/Rsync.hs index ed1eab6..4f4c4eb 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -1,6 +1,6 @@ {- various rsync stuff - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2013 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -92,13 +92,13 @@ rsyncUrlIsPath s | rsyncUrlIsShell s = False | otherwise = ':' `notElem` s -{- Runs rsync, but intercepts its progress output and updates a meter. - - The progress output is also output to stdout. +{- Runs rsync, but intercepts its progress output and updates a progress + - meter. - - The params must enable rsync's --progress mode for this to work. -} -rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool -rsyncProgress meterupdate = commandMeter parseRsyncProgress meterupdate "rsync" . rsyncParamsFixup +rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool +rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup {- Strategy: Look for chunks prefixed with \r (rsync writes a \r before - the first progress output, and each thereafter). The first number diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index 86e60db..f44112b 100644 --- a/Utility/SafeCommand.hs +++ b/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/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index e6a81ae..da05e99 100644 --- a/Utility/ThreadScheduler.hs +++ b/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/Utility/Tmp.hs b/Utility/Tmp.hs index 7599cdd..dc55981 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,6 +1,6 @@ {- Temporary files and directories. - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2013 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} diff --git a/Utility/URI.hs b/Utility/URI.hs index 30c6be3..e68fda5 100644 --- a/Utility/URI.hs +++ b/Utility/URI.hs @@ -1,6 +1,6 @@ {- Network.URI - - - Copyright 2014 Joey Hess <joey@kitenet.net> + - Copyright 2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index c82f040..5bf8d5c 100644 --- a/Utility/UserInfo.hs +++ b/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 -} |