From 146c36ca545a297f1e44e3cf2c91f3c0e17c909f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 3 Feb 2012 16:47:24 -0400 Subject: IO exception rework ghc 7.4 comaplains about use of System.IO.Error to catch exceptions. Ok, use Control.Exception, with variants specialized to only catch IO exceptions. --- Annex/Content.hs | 3 +-- Annex/Journal.hs | 2 +- Annex/Ssh.hs | 4 ++-- Backend.hs | 3 +-- CmdLine.hs | 3 +-- Command/Fsck.hs | 2 +- Common.hs | 1 + Remote/Bup.hs | 3 +-- Upgrade/V0.hs | 4 +--- Upgrade/V1.hs | 5 ++--- Utility/Directory.hs | 8 ++++---- Utility/Exception.hs | 39 +++++++++++++++++++++++++++++++++++++++ Utility/Misc.hs | 21 --------------------- Utility/TempFile.hs | 2 +- 14 files changed, 56 insertions(+), 44 deletions(-) create mode 100644 Utility/Exception.hs diff --git a/Annex/Content.hs b/Annex/Content.hs index dcfd43866..d10370bc9 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -25,7 +25,6 @@ module Annex.Content ( preseedTmp, ) where -import System.IO.Error (try) import Control.Exception (bracket_) import System.Posix.Types @@ -79,7 +78,7 @@ lockContent key a = do where lock Nothing = return Nothing lock (Just l) = do - v <- try $ setLock l (WriteLock, AbsoluteSeek, 0, 0) + v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0) case v of Left _ -> error "content is locked" Right _ -> return $ Just l diff --git a/Annex/Journal.hs b/Annex/Journal.hs index 9c5be89b1..34c4d98c8 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -91,4 +91,4 @@ lockJournal a = do {- Runs an action, catching failure and running something to fix it up, and - retrying if necessary. -} doRedo :: IO a -> IO b -> IO a -doRedo a b = catch a $ const $ b >> a +doRedo a b = catchIO a $ const $ b >> a diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 14ea74e53..d6f36e868 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -11,7 +11,6 @@ module Annex.Ssh ( ) where import qualified Data.Map as M -import System.IO.Error (try) import Common.Annex import Annex.LockPool @@ -72,7 +71,8 @@ sshCleanup = do let lockfile = socket2lock socketfile unlockFile lockfile fd <- liftIO $ openFd lockfile ReadWrite (Just stdFileMode) defaultFileFlags - v <- liftIO $ try $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) + v <- liftIO $ tryIO $ + setLock fd (WriteLock, AbsoluteSeek, 0, 0) case v of Left _ -> return () Right _ -> stopssh socketfile diff --git a/Backend.hs b/Backend.hs index 003d62bfc..e351bb3b2 100644 --- a/Backend.hs +++ b/Backend.hs @@ -16,7 +16,6 @@ module Backend ( maybeLookupBackendName ) where -import System.IO.Error (try) import System.Posix.Files import Common.Annex @@ -77,7 +76,7 @@ genKey' (b:bs) file = do - by examining what the file symlinks to. -} lookupFile :: FilePath -> Annex (Maybe (Key, Backend)) lookupFile file = do - tl <- liftIO $ try getsymlink + tl <- liftIO $ tryIO getsymlink case tl of Left _ -> return Nothing Right l -> makekey l diff --git a/CmdLine.hs b/CmdLine.hs index 61e6c26bb..18bb5fe51 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -11,7 +11,6 @@ module CmdLine ( shutdown ) where -import qualified System.IO.Error as IO import qualified Control.Exception as E import Control.Exception (throw) import System.Console.GetOpt @@ -74,7 +73,7 @@ tryRun' errnum _ cmd [] | otherwise = return () tryRun' errnum state cmd (a:as) = run >>= handle where - run = IO.try $ Annex.run state $ do + run = tryIO $ Annex.run state $ do Annex.Queue.flushWhenFull a handle (Left err) = showerr err >> cont False state diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 59af29edb..469fad749 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -81,7 +81,7 @@ performRemote key file backend numcopies remote = do t <- fromRepo gitAnnexTmpDir let tmp = t "fsck" ++ show pid ++ "." ++ keyFile key liftIO $ createDirectoryIfMissing True t - let cleanup = liftIO $ catch (removeFile tmp) (const $ return ()) + let cleanup = liftIO $ catchIO (removeFile tmp) (const $ return ()) cleanup cleanup `after` a tmp getfile tmp = do diff --git a/Common.hs b/Common.hs index fb998214b..cc6cf9252 100644 --- a/Common.hs +++ b/Common.hs @@ -21,6 +21,7 @@ import System.Posix.Process as X hiding (executeFile) import System.Exit as X import Utility.Misc as X +import Utility.Exception as X import Utility.SafeCommand as X import Utility.Path as X import Utility.Directory as X diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 9b54d8c85..50c3b10b3 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -8,7 +8,6 @@ module Remote.Bup (remote) where import qualified Data.ByteString.Lazy.Char8 as L -import System.IO.Error import qualified Data.Map as M import System.Process @@ -200,7 +199,7 @@ getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo) getBupUUID r u | Git.repoIsUrl r = return (u, r) | otherwise = liftIO $ do - ret <- try $ Git.Config.read r + ret <- tryIO $ Git.Config.read r case ret of Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r') Left _ -> return (NoUUID, r) diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index c5310c641..c439c7caa 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -7,8 +7,6 @@ module Upgrade.V0 where -import System.IO.Error (try) - import Common.Annex import Annex.Content import qualified Upgrade.V1 @@ -47,7 +45,7 @@ getKeysPresent0 dir = do return $ map fileKey0 files where present d = do - result <- try $ + result <- tryIO $ getFileStatus $ dir ++ "/" ++ takeFileName d case result of Right s -> return $ isRegularFile s diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index add50fcf3..ca2bff661 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -7,7 +7,6 @@ module Upgrade.V1 where -import System.IO.Error (try) import System.Posix.Types import Data.Char @@ -183,7 +182,7 @@ readLog1 file = catchDefaultIO (parseLog <$> readFileStrict file) [] lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend)) lookupFile1 file = do - tl <- liftIO $ try getsymlink + tl <- liftIO $ tryIO getsymlink case tl of Left _ -> return Nothing Right l -> makekey l @@ -216,7 +215,7 @@ getKeyFilesPresent1' dir = do liftIO $ filterM present files where present f = do - result <- try $ getFileStatus f + result <- tryIO $ getFileStatus f case result of Right s -> return $ isRegularFile s Left _ -> return False diff --git a/Utility/Directory.hs b/Utility/Directory.hs index b5fedb9c7..e7b7c442b 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,11 +16,12 @@ import Control.Monad.IfElse import Utility.SafeCommand import Utility.TempFile +import Utility.Exception {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} moveFile :: FilePath -> FilePath -> IO () -moveFile src dest = try (rename src dest) >>= onrename +moveFile src dest = tryIO (rename src dest) >>= onrename where onrename (Right _) = return () onrename (Left e) @@ -40,11 +41,10 @@ moveFile src dest = try (rename src dest) >>= onrename Param src, Param tmp] unless ok $ do -- delete any partial - _ <- try $ - removeFile tmp + _ <- tryIO $ removeFile tmp rethrow isdir f = do - r <- try (getFileStatus f) + r <- tryIO $ getFileStatus f case r of (Left _) -> return False (Right s) -> return $ isDirectory s diff --git a/Utility/Exception.hs b/Utility/Exception.hs new file mode 100644 index 000000000..7b6c9c999 --- /dev/null +++ b/Utility/Exception.hs @@ -0,0 +1,39 @@ +{- Simple IO exception handling + - + - Copyright 2011-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Exception where + +import Prelude hiding (catch) +import Control.Exception +import Control.Applicative + +{- Catches IO errors and returns a Bool -} +catchBoolIO :: IO Bool -> IO Bool +catchBoolIO a = catchDefaultIO a False + +{- Catches IO errors and returns a Maybe -} +catchMaybeIO :: IO a -> IO (Maybe a) +catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing + +{- Catches IO errors and returns a default value. -} +catchDefaultIO :: IO a -> a -> IO a +catchDefaultIO a def = catchIO a (const $ return def) + +{- Catches IO errors and returns the error message. -} +catchMsgIO :: IO a -> IO (Either String a) +catchMsgIO a = dispatch <$> tryIO a + where + dispatch (Left e) = Left $ show e + dispatch (Right v) = Right v + +{- catch specialized for IO errors only -} +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = catch + +{- try specialized for IO errors only -} +tryIO :: IO a -> IO (Either IOException a) +tryIO = try diff --git a/Utility/Misc.hs b/Utility/Misc.hs index c9bfcb953..3ac5ca5c0 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -8,9 +8,7 @@ module Utility.Misc where import System.IO -import System.IO.Error (try) import Control.Monad -import Control.Applicative {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} @@ -37,22 +35,3 @@ separate c l = unbreak $ break c l {- Breaks out the first line. -} firstLine :: String-> String firstLine = takeWhile (/= '\n') - -{- Catches IO errors and returns a Bool -} -catchBoolIO :: IO Bool -> IO Bool -catchBoolIO a = catchDefaultIO a False - -{- Catches IO errors and returns a Maybe -} -catchMaybeIO :: IO a -> IO (Maybe a) -catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing - -{- Catches IO errors and returns a default value. -} -catchDefaultIO :: IO a -> a -> IO a -catchDefaultIO a def = catch a (const $ return def) - -{- Catches IO errors and returns the error message. -} -catchMsgIO :: IO a -> IO (Either String a) -catchMsgIO a = dispatch <$> try a - where - dispatch (Left e) = Left $ show e - dispatch (Right v) = Right v diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs index 469d52e8c..4dcbf1cca 100644 --- a/Utility/TempFile.hs +++ b/Utility/TempFile.hs @@ -12,7 +12,7 @@ import System.IO import System.Posix.Process hiding (executeFile) import System.Directory -import Utility.Misc +import Utility.Exception import Utility.Path {- Runs an action like writeFile, writing to a temp file first and -- cgit v1.2.3