@@ -1,8 +1,9 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}
3module Network.Wai.Handler.Warp.Settings where
3module Network.Wai.Handler.Warp.Settings where
5import Control.Exception
5import Control.Exception
6+import Control.Monad (when)
6import qualified Data.ByteString as S
7import qualified Data.ByteString as S
7import qualified Data.Text as T
8import qualified Data.Text as T
8import qualified Data.Text.IO as TIO
9import qualified Data.Text.IO as TIO
@@ -76,30 +77,24 @@ defaultSettings = Settings
76 , settingsNoParsePath = False
77 , settingsNoParsePath = False
79−defaultExceptionHandler :: Maybe Request -> SomeException -> IO ()
80+-- | Apply the logic provided by 'defaultExceptionHandler' to determine if an
80−defaultExceptionHandler _ e = throwIO e `catches` handlers
81+-- exception should be shown or not. The goal is to hide exceptions which occur
81− where
82+-- under the normal course of the web server running.
82− handlers = [Handler ah, Handler ih, Handler oh, Handler th, Handler sh]
83+--
84− ah :: AsyncException -> IO ()
85+defaultShouldDisplayException :: SomeException -> Bool
86+defaultShouldDisplayException se
85− ah ThreadKilled = return ()
87+ | Just ThreadKilled <- fromException se = False
86− ah x = hPrint stderr x
88− ih :: InvalidRequest -> IO ()
88+ | Just (_ :: InvalidRequest) <- fromException se = False
89− ih _ = return ()
89+ | Just (ioeGetErrorType -> et) <- fromException se
91− oh :: IOException -> IO ()
93− | et == ResourceVanished || et == InvalidArgument = return ()
90+ , et == ResourceVanished || et == InvalidArgument = False
91+ | Just TimeoutThread <- fromException se = False
94− | otherwise = hPrint stderr x
92+ | otherwise = True
96− et = ioeGetErrorType x
98− th :: TimeoutThread -> IO ()
99− th TimeoutThread = return ()
101− sh :: SomeException -> IO ()
94+defaultExceptionHandler :: Maybe Request -> SomeException -> IO ()
95+defaultExceptionHandler _ e =
96+ when (defaultShouldDisplayException e)
102− sh = TIO.hPutStrLn stderr . T.pack . show
97+ $ TIO.hPutStrLn stderr $ T.pack $ show e
104defaultExceptionResponse :: SomeException -> Response
99defaultExceptionResponse :: SomeException -> Response
105defaultExceptionResponse _ = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"
100defaultExceptionResponse _ = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"