{- Simple IO exception handling (and some more)
 -
 - Copyright 2011-2015 Joey Hess <id@joeyh.name>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}

module Utility.Exception (
	module X,
	catchBoolIO,
	catchMaybeIO,
	catchDefaultIO,
	catchMsgIO,
	catchIO,
	tryIO,
	bracketIO,
	catchNonAsync,
	tryNonAsync,
	tryWhenExists,
	catchHardwareFault,
) where

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, ioeGetErrorType)
import GHC.IO.Exception (IOErrorType(..))

{- Catches IO errors and returns a Bool -}
catchBoolIO :: MonadCatch m => m Bool -> m Bool
catchBoolIO :: forall (m :: * -> *). MonadCatch m => m Bool -> m Bool
catchBoolIO = Bool -> m Bool -> m Bool
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO Bool
False

{- Catches IO errors and returns a Maybe -}
catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
catchMaybeIO :: forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO m a
a = Maybe a -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO Maybe a
forall a. Maybe a
Nothing (m (Maybe a) -> m (Maybe a)) -> m (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ m a
a m a -> (a -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)

{- Catches IO errors and returns a default value. -}
catchDefaultIO :: MonadCatch m => a -> m a -> m a
catchDefaultIO :: forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO a
def m a
a = m a -> (IOException -> m a) -> m a
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO m a
a (m a -> IOException -> m a
forall a b. a -> b -> a
const (m a -> IOException -> m a) -> m a -> IOException -> m a
forall a b. (a -> b) -> a -> b
$ a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
def)

{- Catches IO errors and returns the error message. -}
catchMsgIO :: MonadCatch m => m a -> m (Either String a)
catchMsgIO :: forall (m :: * -> *) a. MonadCatch m => m a -> m (Either String a)
catchMsgIO m a
a = do
	Either IOException a
v <- m a -> m (Either IOException a)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO m a
a
	Either String a -> m (Either String a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> m (Either String a))
-> Either String a -> m (Either String a)
forall a b. (a -> b) -> a -> b
$ (IOException -> Either String a)
-> (a -> Either String a)
-> Either IOException a
-> Either String a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (IOException -> String) -> IOException -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show) a -> Either String a
forall a b. b -> Either a b
Right Either IOException a
v

{- catch specialized for IO errors only -}
catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a
catchIO :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO = m a -> (IOException -> m a) -> m a
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
M.catch

{- try specialized for IO errors only -}
tryIO :: MonadCatch m => m a -> m (Either IOException a)
tryIO :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO = m a -> m (Either IOException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
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 :: forall (m :: * -> *) v b a.
(MonadMask m, MonadIO m) =>
IO v -> (v -> IO b) -> (v -> m a) -> m a
bracketIO IO v
setup v -> IO b
cleanup = m v -> (v -> m b) -> (v -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO v -> m v
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO v
setup) (IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> (v -> IO b) -> v -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> IO b
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 :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchNonAsync m a
a SomeException -> m a
onerr = m a
a m a -> [Handler m a] -> m a
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
`catches`
	[ (AsyncException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
M.Handler (\ (AsyncException
e :: AsyncException) -> AsyncException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM AsyncException
e)
	, (SomeException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
M.Handler (\ (SomeException
e :: SomeException) -> SomeException -> m a
onerr SomeException
e)
	]

tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)
tryNonAsync :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryNonAsync m a
a = m (Either SomeException a)
forall {a}. m (Either a a)
go m (Either SomeException a)
-> (SomeException -> m (Either SomeException a))
-> m (Either SomeException a)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchNonAsync` (Either SomeException a -> m (Either SomeException a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> m (Either SomeException a))
-> (SomeException -> Either SomeException a)
-> SomeException
-> m (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left)
  where
	go :: m (Either a a)
go = do
		a
v <- m a
a
		Either a a -> m (Either a a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a a
forall a b. b -> Either a b
Right a
v)

{- Catches only DoesNotExist exceptions, and lets all others through. -}
tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
tryWhenExists :: forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
tryWhenExists m a
a = do
	Either () a
v <- (IOException -> Maybe ()) -> m a -> m (Either () a)
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ())
-> (IOException -> Bool) -> IOException -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Bool
isDoesNotExistError) m a
a
	Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((() -> Maybe a) -> (a -> Maybe a) -> Either () a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> () -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just Either () a
v)

{- Catches only exceptions caused by hardware faults.
 - Ie, disk IO error. -}
catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a
catchHardwareFault :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchHardwareFault m a
a IOException -> m a
onhardwareerr = m a -> (IOException -> m a) -> m a
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO m a
a IOException -> m a
onlyhw
  where
	onlyhw :: IOException -> m a
onlyhw IOException
e
		| IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
HardwareFault = IOException -> m a
onhardwareerr IOException
e
		| Bool
otherwise = IOException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM IOException
e