@@ -1,15 +1,16 @@
11module Network.Wai.Handler.Warp.Settings where
22
33import Control.Exception
4−import Control.Monad
54import qualified Data.ByteString as S
65import qualified Data.ByteString.Char8 as S8
76import Data.Conduit
87import Data.Conduit.Network (HostPreference (HostIPv4))
8+import GHC.IO.Exception (IOErrorType(..))
99import Network.Wai
1010import Network.Wai.Handler.Warp.Timeout
1111import Network.Wai.Handler.Warp.Types
1212import System.IO (hPrint, stderr)
13+import System.IO.Error (ioeGetErrorType)
1314
1415-- | Various Warp server settings. This is purposely kept as an abstract data
1516-- type so that new settings can be added without breaking backwards
@@ -54,12 +55,7 @@ defaultSettings :: Settings
5455defaultSettings = Settings
5556 { settingsPort = 3000
5657 , settingsHost = HostIPv4
57− , settingsOnException = \e ->
58− case fromException e of
59− Just x -> go x
60− Nothing ->
61− when (go' $ fromException e) $
62− hPrint stderr e
58+ , settingsOnException = defaultExceptionHandler
6359 , settingsOnOpen = return ()
6460 , settingsOnClose = return ()
6561 , settingsTimeout = 30
@@ -70,8 +66,26 @@ defaultSettings = Settings
7066 , settingsBeforeMainLoop = return ()
7167 , settingsServerName = S8.pack $ "Warp/" ++ warpVersion
7268 }
69+
70+defaultExceptionHandler :: SomeException -> IO ()
71+defaultExceptionHandler e = throwIO e `catches` handlers
7372 where
74− go :: InvalidRequest -> IO ()
75− go _ = return ()
76− go' (Just ThreadKilled) = False
77− go' _ = True
73+ handlers = [Handler ah, Handler ih, Handler oh, Handler sh]
74+
75+ ah :: AsyncException -> IO ()
76+ ah ThreadKilled = return ()
77+ ah x = hPrint stderr x
78+
79+ ih :: InvalidRequest -> IO ()
80+ ih _ = return ()
81+
82+ oh :: IOException -> IO ()
83+ oh x
84+ | et `elem` ignEt = return ()
85+ | otherwise = hPrint stderr x
86+ where
87+ et = ioeGetErrorType x
88+ ignEt = [ResourceVanished, InvalidArgument]
89+
90+ sh :: SomeException -> IO ()
91+ sh x = hPrint stderr x