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.
This commit is contained in:
Joey Hess 2012-02-03 16:47:24 -04:00
parent 05f89123e0
commit 146c36ca54
14 changed files with 56 additions and 44 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

39
Utility/Exception.hs Normal file
View file

@ -0,0 +1,39 @@
{- Simple IO exception handling
-
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
-
- 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

View file

@ -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

View file

@ -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