git-annex/Utility/Exception.hs
Joey Hess 7013798df5
async exception safety for coprocesses
Tested the forcerestart code path and it works.

The hairy part is, what if an async exception is caught when it's in
restart?

If it's in the part that stops the old process, the old process
is left in the handle. The next attempt to use the CoProcessHandle
will then throw an IO exception, which will result in restart getting
run again. So I think this will work, but have not actually tested it.

The use of withMVarMasked lets it start the new process and fill the
mvar with it, even if there's an async exception at that point.

Note that exceptions are masked while running forcerestart, so
do not need to worry about an async exception being thrown while it's
recovering from an async exception.
2020-06-09 13:44:23 -04:00

122 lines
3.9 KiB
Haskell

{- Simple IO exception handling (and some more)
-
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Exception (
module X,
giveup,
catchBoolIO,
catchMaybeIO,
catchDefaultIO,
catchMsgIO,
catchIO,
tryIO,
bracketIO,
catchNonAsync,
tryNonAsync,
catchAsync,
tryWhenExists,
catchIOErrorType,
IOErrorType(..),
catchPermissionDenied,
) where
import Control.Monad.Catch as X hiding (Handler)
import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
import Control.Exception (SomeAsyncException)
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
import GHC.IO.Exception (IOErrorType(..))
import Utility.Data
{- Like error, this throws an exception. Unlike error, if this exception
- is not caught, it won't generate a backtrace. So use this for situations
- where there's a problem that the user is expeected to see in some
- circumstances. -}
giveup :: [Char] -> a
giveup = errorWithoutStackTrace
{- Catches IO errors and returns a Bool -}
catchBoolIO :: MonadCatch m => m Bool -> m Bool
catchBoolIO = catchDefaultIO False
{- Catches IO errors and returns a Maybe -}
catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just)
{- Catches IO errors and returns a default value. -}
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 :: 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 :: MonadCatch m => m a -> (IOException -> m a) -> m a
catchIO = M.catch
{- try specialized for IO errors only -}
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 :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchNonAsync a onerr = a `catches`
[ M.Handler (\ (e :: AsyncException) -> throwM e)
, M.Handler (\ (e :: SomeAsyncException) -> throwM e)
, M.Handler (\ (e :: SomeException) -> onerr e)
]
{- Catches only async exceptions. -}
catchAsync :: MonadCatch m => m a -> (Either AsyncException SomeAsyncException -> m a) -> m a
catchAsync a onerr = a `catches`
[ M.Handler (\ (e :: AsyncException) -> onerr (Left e))
, M.Handler (\ (e :: SomeAsyncException) -> onerr (Right e))
, M.Handler (\ (e :: SomeException) -> throwM e)
]
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 :: MonadCatch m => m a -> m (Maybe a)
tryWhenExists a = do
v <- tryJust (guard . isDoesNotExistError) a
return (eitherToMaybe v)
{- Catches only IO exceptions of a particular type.
- Ie, use HardwareFault to catch disk IO errors. -}
catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a
catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching
where
onlymatching e
| ioeGetErrorType e == errtype = onmatchingerr e
| otherwise = throwM e
catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a
catchPermissionDenied = catchIOErrorType PermissionDenied