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