6de28ae · typeable/wai

git.iko.soy/typeable/wai

implementing settingsOnExceptionResponse for #218.

commit6de28ae764cdde241ccc3f31f57419161537afe5 authorKazu Yamamoto <kazu@iij.ad.jp> dateSat 18 Jan 2014, 14:34 (13 years ago) parent33d4af8

3 files changed+28−5

compare with master

unifiedsplit

warp/Network/Wai/Handler/Warp.hs+3 warp/Network/Wai/Handler/Warp/Run.hs+7−5 warp/Network/Wai/Handler/Warp/Settings.hs+18

warp/Network/Wai/Handler/Warp.hs+3

@@ -29,6 +29,7 @@ module Network.Wai.Handler.Warp (

2929 , settingsPort

3030 , settingsHost

3131 , settingsOnException

32+ , settingsOnExceptionResponse

3233 , settingsOnOpen

3334 , settingsOnClose

3435 , settingsTimeout

@@ -37,6 +38,8 @@ module Network.Wai.Handler.Warp (

3738 , settingsFdCacheDuration

3839 , settingsBeforeMainLoop

3940 , settingsNoParsePath

41+ -- ** Debugging

42+ , exceptionResponseForDebug

4043 -- * Data types

4144 , HostPreference (..)

4245 , Port

warp/Network/Wai/Handler/Warp/Run.hs+7−5

@@ -16,7 +16,6 @@ import Data.Conduit.Internal (ResumableSource (..))

1616import qualified Data.Conduit.List as CL

1717import Data.Conduit.Network (bindPort)

1818import Network (sClose, Socket)

19−import qualified Network.HTTP.Types as H

2019import Network.Socket (accept, SockAddr)

2120import qualified Network.Socket.ByteString as Sock

2221import Network.Wai

@@ -218,18 +217,21 @@ serveConnection :: Connection

218217 -> IO ()

219218serveConnection conn ii addr settings app = do

220219 istatus <- newIORef False

221− recvSendLoop istatus (connSource conn th istatus) `onException` send500 istatus

220+ recvSendLoop istatus (connSource conn th istatus) `E.catch` \e -> do

221+ sendErrorResponse istatus e

222+ throwIO (e :: SomeException)

223+

222224 where

223225 th = threadHandle ii

224226

225− send500 istatus = do

227+ sendErrorResponse istatus e = do

226228 status <- readIORef istatus

227229 when status $ void $ mask $ \restore ->

228− sendResponse conn ii restore dummyreq defaultIndexRequestHeader internalError

230+ sendResponse conn ii restore dummyreq defaultIndexRequestHeader (errorResponse e)

229231

230232 dummyreq = defaultRequest { remoteHost = addr }

231233

232− internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"

234+ errorResponse e = settingsOnExceptionResponse settings e

233235

234236 recvSendLoop istatus fromClient = do

235237 (req, idxhdr, getSource) <- recvRequest settings conn ii addr fromClient

warp/Network/Wai/Handler/Warp/Settings.hs+18

@@ -1,10 +1,14 @@

1+{-# LANGUAGE OverloadedStrings #-}

13module Network.Wai.Handler.Warp.Settings where

35import Control.Exception

46import qualified Data.ByteString as S

7+import qualified Data.ByteString.Lazy.Char8 as L8

58import Data.Conduit

69import Data.Conduit.Network (HostPreference (HostIPv4))

710import GHC.IO.Exception (IOErrorType(..))

11+import qualified Network.HTTP.Types as H

812import Network.Wai

913import Network.Wai.Handler.Warp.Timeout

1014import Network.Wai.Handler.Warp.Types

@@ -21,6 +25,12 @@ data Settings = Settings

2125 { settingsPort :: Int -- ^ Port to listen on. Default value: 3000

2226 , settingsHost :: HostPreference -- ^ Default value: HostIPv4

2327 , settingsOnException :: Maybe Request -> SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.

28+ , settingsOnExceptionResponse :: SomeException -> Response

29+ -- ^ A function to create `Response` when an exception occurs.

30+ --

31+ -- Default: 500, text/plain, \"Something went wrong\"

32+ --

33+ -- Since 2.0.3

2434 , settingsOnOpen :: IO () -- ^ What to do when a connection is open. Default: do nothing.

2535 , settingsOnClose :: IO () -- ^ What to do when a connection is close. Default: do nothing.

2636 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30

@@ -52,6 +62,7 @@ defaultSettings = Settings

5262 { settingsPort = 3000

5363 , settingsHost = HostIPv4

5464 , settingsOnException = defaultExceptionHandler

65+ , settingsOnExceptionResponse = defaultExceptionResponse

5566 , settingsOnOpen = return ()

5667 , settingsOnClose = return ()

5768 , settingsTimeout = 30

@@ -83,3 +94,10 @@ defaultExceptionHandler _ e = throwIO e `catches` handlers

8394

8495 sh :: SomeException -> IO ()

8596 sh x = hPrint stderr x

97+

98+defaultExceptionResponse :: SomeException -> Response

99+defaultExceptionResponse _ = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"

100+

101+-- | Default implementation of 'settingsOnExceptionResponse' for the debugging purpose. 500, text/plain, a showed exception.

102+exceptionResponseForDebug :: SomeException -> Response

103+exceptionResponseForDebug e = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] (L8.pack $ "Exception: " ++ show e)