From efef527d5b2e42e261fa7af6947aad6553426ebe Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 12 Oct 2014 14:32:56 -0400 Subject: Merge from git-annex. Includes changing to new exceptions library, and some whitespace fixes. --- Utility/Batch.hs | 2 +- Utility/CoProcess.hs | 4 +-- Utility/Directory.hs | 7 ++-- Utility/Exception.hs | 75 ++++++++++++++++++++++++++++++------------- Utility/FileMode.hs | 1 - Utility/FileSystemEncoding.hs | 2 +- Utility/Format.hs | 2 +- Utility/Metered.hs | 19 +++++++++++ Utility/Path.hs | 8 ++--- Utility/Process.hs | 1 + Utility/Rsync.hs | 12 ++----- Utility/Tmp.hs | 24 +++++++------- 12 files changed, 99 insertions(+), 58 deletions(-) (limited to 'Utility') diff --git a/Utility/Batch.hs b/Utility/Batch.hs index d6dadae..ff81318 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -32,7 +32,7 @@ batch :: IO a -> IO a #if defined(linux_HOST_OS) || defined(__ANDROID__) batch a = wait =<< batchthread where - batchthread = asyncBound $ do + batchthread = asyncBound $ do setProcessPriority 0 maxNice a #else diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index 332c09d..97826ec 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -65,7 +65,7 @@ query ch send receive = do restartable s (receive $ coProcessFrom s) return where - restartable s a cont + restartable s a cont | coProcessNumRestarts (coProcessSpec s) > 0 = maybe restart cont =<< catchMaybeIO a | otherwise = cont =<< a @@ -87,7 +87,7 @@ rawMode ch = do raw $ coProcessTo s return ch where - raw h = do + raw h = do fileEncoding h #ifdef mingw32_HOST_OS hSetNewlineMode h noNewlineTranslation diff --git a/Utility/Directory.hs b/Utility/Directory.hs index ade5ef8..e4e4b80 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -11,7 +11,6 @@ module Utility.Directory where import System.IO.Error import System.Directory -import Control.Exception (throw, bracket) import Control.Monad import Control.Monad.IfElse import System.FilePath @@ -57,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 @@ -88,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 @@ -114,7 +113,7 @@ moveFile src dest = tryIO (rename src dest) >>= onrename whenM (isdir dest) rethrow viaTmp mv dest undefined where - rethrow = throw e + rethrow = throwM e mv tmp _ = do ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] unless ok $ do diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 1fecf65..ef3ab1d 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,59 +1,88 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2012 Joey Hess + - Copyright 2011-2014 Joey Hess - - 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/Utility/FileMode.hs b/Utility/FileMode.hs index c2ef683..832250b 100644 --- a/Utility/FileMode.hs +++ b/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 diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index b81fdc5..fa4b39a 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -111,7 +111,7 @@ truncateFilePath :: Int -> FilePath -> FilePath #ifndef mingw32_HOST_OS truncateFilePath n = go . reverse where - go f = + go f = let bytes = decodeW8 f in if length bytes <= n then reverse f diff --git a/Utility/Format.hs b/Utility/Format.hs index 2a5ae5c..78620f9 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -117,7 +117,7 @@ decode_c s = unescape ("", s) handle (x:'x':n1:n2:rest) | isescape x && allhex = (fromhex, rest) where - allhex = isHexDigit n1 && isHexDigit n2 + allhex = isHexDigit n1 && isHexDigit n2 fromhex = [chr $ readhex [n1, n2]] readhex h = Prelude.read $ "0x" ++ h :: Int handle (x:n1:n2:n3:rest) diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 0d94c1c..4618aec 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -16,6 +16,7 @@ import qualified Data.ByteString as S import System.IO.Unsafe import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types +import Data.Int {- An action that can be run repeatedly, updating it on the bytes processed. - @@ -23,6 +24,9 @@ import System.Posix.Types - far, *not* an incremental amount since the last call. -} type MeterUpdate = (BytesProcessed -> IO ()) +nullMeterUpdate :: MeterUpdate +nullMeterUpdate _ = return () + {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer deriving (Eq, Ord, Show) @@ -31,6 +35,10 @@ class AsBytesProcessed a where toBytesProcessed :: a -> BytesProcessed fromBytesProcessed :: BytesProcessed -> a +instance AsBytesProcessed BytesProcessed where + toBytesProcessed = id + fromBytesProcessed = id + instance AsBytesProcessed Integer where toBytesProcessed i = BytesProcessed i fromBytesProcessed (BytesProcessed i) = i @@ -39,6 +47,10 @@ instance AsBytesProcessed Int where toBytesProcessed i = BytesProcessed $ toInteger i fromBytesProcessed (BytesProcessed i) = fromInteger i +instance AsBytesProcessed Int64 where + toBytesProcessed i = BytesProcessed $ toInteger i + fromBytesProcessed (BytesProcessed i) = fromInteger i + instance AsBytesProcessed FileOffset where toBytesProcessed sz = BytesProcessed $ toInteger sz fromBytesProcessed (BytesProcessed sz) = fromInteger sz @@ -77,6 +89,13 @@ meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h -> meteredWrite meterupdate h b +{- Applies an offset to a MeterUpdate. This can be useful when + - performing a sequence of actions, such as multiple meteredWriteFiles, + - that all update a common meter progressively. Or when resuming. + -} +offsetMeterUpdate :: MeterUpdate -> BytesProcessed -> MeterUpdate +offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n) + {- This is like L.hGetContents, but after each chunk is read, a meter - is updated based on the size of the chunk. - diff --git a/Utility/Path.hs b/Utility/Path.hs index 99c9438..9035cbc 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -235,11 +235,11 @@ toCygPath p | null drive = recombine parts | otherwise = recombine $ "/cygdrive" : driveletter drive : parts where - (drive, p') = splitDrive p + (drive, p') = splitDrive p parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') + driveletter = map toLower . takeWhile (/= ':') recombine = fixtrailing . Posix.joinPath - fixtrailing s + fixtrailing s | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s | otherwise = s #endif @@ -272,7 +272,7 @@ fileNameLengthLimit dir = do sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize where - sanitize c + sanitize c | c == '.' = c | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' | otherwise = c diff --git a/Utility/Process.hs b/Utility/Process.hs index 1f722af..e25618e 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -31,6 +31,7 @@ module Utility.Process ( stdinHandle, stdoutHandle, stderrHandle, + bothHandles, processHandle, devNull, ) where diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 6038126..8dee609 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -57,7 +57,7 @@ rsync = boolSystem "rsync" . rsyncParamsFixup rsyncParamsFixup :: [CommandParam] -> [CommandParam] rsyncParamsFixup = map fixup where - fixup (File f) = File (toCygPath f) + fixup (File f) = File (toCygPath f) fixup p = p {- Runs rsync, but intercepts its progress output and updates a meter. @@ -66,14 +66,8 @@ rsyncParamsFixup = map fixup - The params must enable rsync's --progress mode for this to work. -} rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool -rsyncProgress meterupdate params = do - r <- catchBoolIO $ - withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) - {- For an unknown reason, piping rsync's output like this does - - causes it to run a second ssh process, which it neglects to wait - - on. Reap the resulting zombie. -} - reapZombies - return r +rsyncProgress meterupdate params = catchBoolIO $ + withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) where p = proc "rsync" (toCommand $ rsyncParamsFixup params) feedprogress prev buf h = do diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index bed30bb..edd82f5 100644 --- a/Utility/Tmp.hs +++ b/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 @@ -32,31 +32,31 @@ viaTmp a file content = bracket setup cleanup use setup = do createDirectoryIfMissing True dir openTempFile dir template - cleanup (tmpfile, handle) = do - _ <- tryIO $ hClose handle + cleanup (tmpfile, h) = do + _ <- tryIO $ hClose h tryIO $ removeFile tmpfile - use (tmpfile, handle) = do - hClose handle + use (tmpfile, h) = do + hClose h a tmpfile content 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 -- cgit v1.2.3