{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}

module HaskellWorks.CabalCache.IO.Error
  ( exceptFatal
  , exceptWarn
  , maybeToExcept
  , maybeToExceptM
  , catchErrno
  ) where

import Control.Monad.Except
import Foreign.C.Error
  (
    getErrno
  , Errno
  )
import HaskellWorks.CabalCache.AppError
import System.IO.Error
  (
    catchIOError
  )

import qualified HaskellWorks.CabalCache.IO.Console as CIO
import qualified System.Exit                        as IO
import qualified System.IO                          as IO

exceptFatal :: MonadIO m => ExceptT AppError m a -> ExceptT AppError m a
exceptFatal :: ExceptT AppError m a -> ExceptT AppError m a
exceptFatal ExceptT AppError m a
f = ExceptT AppError m a
-> (AppError -> ExceptT AppError m a) -> ExceptT AppError m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ExceptT AppError m a
f AppError -> ExceptT AppError m a
forall (m :: * -> *) b.
(MonadIO m, MonadError AppError m) =>
AppError -> m b
handler
  where handler :: AppError -> m b
handler AppError
e = do
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Fatal Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AppError -> Text
displayAppError AppError
e
          m Any -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Any -> m ()) -> m Any -> m ()
forall a b. (a -> b) -> a -> b
$ IO Any -> m Any
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Any
forall a. IO a
IO.exitFailure
          AppError -> m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
e

exceptWarn :: MonadIO m => ExceptT AppError m a -> ExceptT AppError m a
exceptWarn :: ExceptT AppError m a -> ExceptT AppError m a
exceptWarn ExceptT AppError m a
f = ExceptT AppError m a
-> (AppError -> ExceptT AppError m a) -> ExceptT AppError m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ExceptT AppError m a
f AppError -> ExceptT AppError m a
forall (m :: * -> *) b.
(MonadIO m, MonadError AppError m) =>
AppError -> m b
handler
  where handler :: AppError -> m b
handler AppError
e = do
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Warning: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AppError -> Text
displayAppError AppError
e
          AppError -> m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
e

maybeToExcept :: Monad m => AppError -> Maybe a -> ExceptT AppError m a
maybeToExcept :: AppError -> Maybe a -> ExceptT AppError m a
maybeToExcept AppError
message = ExceptT AppError m a
-> (a -> ExceptT AppError m a) -> Maybe a -> ExceptT AppError m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AppError -> ExceptT AppError m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AppError
message) a -> ExceptT AppError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

maybeToExceptM :: Monad m => AppError -> m (Maybe a) -> ExceptT AppError m a
maybeToExceptM :: AppError -> m (Maybe a) -> ExceptT AppError m a
maybeToExceptM AppError
message = m (Either AppError a) -> ExceptT AppError m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either AppError a) -> ExceptT AppError m a)
-> (m (Maybe a) -> m (Either AppError a))
-> m (Maybe a)
-> ExceptT AppError m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Either AppError a)
-> m (Maybe a) -> m (Either AppError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either AppError a
-> (a -> Either AppError a) -> Maybe a -> Either AppError a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AppError -> Either AppError a
forall a b. a -> Either a b
Left AppError
message) a -> Either AppError a
forall a b. b -> Either a b
Right)


-- |Carries out an action, then checks if there is an IOException and
-- a specific errno. If so, then it carries out another action, otherwise
-- it rethrows the error.
catchErrno :: [Errno] -- ^ errno to catch
           -> IO a    -- ^ action to try, which can raise an IOException
           -> IO a    -- ^ action to carry out in case of an IOException and
                      --   if errno matches
           -> IO a
catchErrno :: [Errno] -> IO a -> IO a -> IO a
catchErrno [Errno]
en IO a
a1 IO a
a2 =
  IO a -> (IOError -> IO a) -> IO a
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError IO a
a1 ((IOError -> IO a) -> IO a) -> (IOError -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \IOError
e -> do
    Errno
errno <- IO Errno
getErrno
    if Errno
errno Errno -> [Errno] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Errno]
en
      then IO a
a2
      else IOError -> IO a
forall a. IOError -> IO a
ioError IOError
e