From 9af9872f0f54d5d4af2aed3d08eef9ab67012261 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 6 Jan 2015 19:02:48 -0400 Subject: Merge from git-annex. --- Utility/DottedVersion.hs | 36 +++++++++++++++++++++++++++++ Utility/Metered.hs | 33 ++++++++++++++++++++++++++ Utility/Path.hs | 24 ++++++++++--------- Utility/Rsync.hs | 60 ++++++++++++++++++++---------------------------- Utility/Tmp.hs | 16 ++++++------- Utility/UserInfo.hs | 4 +++- 6 files changed, 118 insertions(+), 55 deletions(-) create mode 100644 Utility/DottedVersion.hs (limited to 'Utility') 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 + - + - 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 -- cgit v1.2.3