Print shorter http exceptions

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

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 ()
+handleExceptions :: (MonadIO m, MonadCatch m) => forall a. m a -> m ()
-handleException slackBuilderException
+handleExceptions action = catches (void action)
-    = liftIO (setSGR [SetColor Foreground Dull Red])
+    [ Handler handleHttp
-    >> liftIO (putStrLn (displayException slackBuilderException))
+    , Handler handleSome
-    >> liftIO (setSGR [Reset])
+    ]
+  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