diff --git a/src/Main.hs b/src/Main.hs index aa89fb4..3e00f18 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,7 +6,7 @@ module Main ( main ) where -import Control.Monad.Catch (MonadThrow(..), handle) +import Control.Monad.Catch (MonadThrow(..)) import Control.Monad.IO.Class (MonadIO(..)) import qualified Data.Map as Map import Options.Applicative (execParser) @@ -84,7 +84,7 @@ up2Date :: Maybe Text -> SlackBuilderT () up2Date selectedPackage = do packages' <- SlackBuilderT $ asks (getField @"packages") case selectedPackage of - Nothing -> traverse_ (handle handleException . go) $ autoUpdatable packages' + Nothing -> traverse_ (handleExceptions . go) $ autoUpdatable packages' Just packageName | Just foundPackage <- find ((packageName ==) . getField @"name") (autoUpdatable packages') -> go foundPackage @@ -96,7 +96,7 @@ up2Date selectedPackage = do check :: SlackBuilderT () check = SlackBuilderT (asks (getField @"packages")) - >>= traverse_ (handle handleException . go) . autoUpdatable + >>= traverse_ (handleExceptions . go) . autoUpdatable where go package = getAndLogLatest package >>= mapM_ checkUpdateAvailability @@ -130,7 +130,7 @@ installed = do main :: IO () main = execParser slackBuilderParser - >>= handle handleException . withCommandLine + >>= handleExceptions . withCommandLine where withCommandLine programCommand = do settingsResult <- Toml.decodeFileEither settingsCodec configurationFile diff --git a/src/SlackBuilder/Update.hs b/src/SlackBuilder/Update.hs index 79964b8..7987916 100644 --- a/src/SlackBuilder/Update.hs +++ b/src/SlackBuilder/Update.hs @@ -7,7 +7,7 @@ module SlackBuilder.Update , cloneFromGit , downloadWithTemplate , getAndLogLatest - , handleException + , handleExceptions , listRepository , repackageWithTemplate , reuploadWithTemplate @@ -15,7 +15,7 @@ module SlackBuilder.Update ) where import Control.Exception (Exception(..), SomeException(..)) -import Control.Monad.Catch (MonadCatch(..)) +import Control.Monad.Catch (MonadCatch(..), catches, Handler(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (asks) import Data.Foldable (Foldable(..), find) @@ -27,6 +27,8 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import GHC.Records (HasField(..)) +import qualified Network.HTTP.Req as Req +import Network.HTTP.Client (HttpException(..)) import System.FilePath ( () , (<.>) @@ -65,7 +67,7 @@ import System.Console.ANSI , Color(..) , ConsoleLayer(..) ) -import Control.Monad (filterM) +import Control.Monad (filterM, void) import Data.List (isPrefixOf, isSuffixOf, partition) import Data.Functor ((<&>)) import Data.Bifunctor (Bifunctor(..)) @@ -266,8 +268,21 @@ listRepository = do in filterM directoryFilter accumulatedDirectories >>= traverse (go currentDirectory found) <&> concat -handleException :: (MonadIO m, MonadCatch m) => SomeException -> m () -handleException slackBuilderException - = liftIO (setSGR [SetColor Foreground Dull Red]) - >> liftIO (putStrLn (displayException slackBuilderException)) - >> liftIO (setSGR [Reset]) +handleExceptions :: (MonadIO m, MonadCatch m) => forall a. m a -> m () +handleExceptions action = catches (void action) + [ Handler handleHttp + , Handler handleSome + ] + where + printException e + = liftIO (setSGR [SetColor Foreground Dull Red]) + >> liftIO (putStrLn e) + >> liftIO (setSGR [Reset]) + handleHttp :: (MonadIO m, MonadCatch m) => Req.HttpException -> m () + handleHttp (Req.VanillaHttpException e) + | HttpExceptionRequest _ exceptionContent <- e = printException + $ show exceptionContent + | InvalidUrlException url reason <- e = printException $ url <> ": " <> reason + handleHttp (Req.JsonHttpException e) = printException e + handleSome :: (MonadIO m, MonadCatch m) => SomeException -> m () + handleSome = printException . displayException