summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
Diffstat (limited to 'Utility')
-rw-r--r--Utility/Batch.hs2
-rw-r--r--Utility/CoProcess.hs4
-rw-r--r--Utility/Directory.hs7
-rw-r--r--Utility/Exception.hs75
-rw-r--r--Utility/FileMode.hs1
-rw-r--r--Utility/FileSystemEncoding.hs2
-rw-r--r--Utility/Format.hs2
-rw-r--r--Utility/Metered.hs19
-rw-r--r--Utility/Path.hs8
-rw-r--r--Utility/Process.hs1
-rw-r--r--Utility/Rsync.hs12
-rw-r--r--Utility/Tmp.hs24
12 files changed, 99 insertions, 58 deletions
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 <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
-
- 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-30 23:06:17 +0000