7c73d7e · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Still make an HTTP response after an exception

7c73d7eStephen Paul Weber13 years ago

warp/Network/Wai/Handler/Warp/Run.hs+13−1

compare with master

unifiedsplit

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4module Network.Wai.Handler.Warp.Run where

5module Network.Wai.Handler.Warp.Run where

@@ -18,6 +19,8 @@ import Network (sClose, Socket)

18import Network.Sendfile

19import Network.Sendfile

19import Network.Socket (accept, SockAddr)

20import Network.Socket (accept, SockAddr)

20import qualified Network.Socket.ByteString as Sock

21import qualified Network.Socket.ByteString as Sock

22+import Data.Monoid (mempty)

23+import qualified Network.HTTP.Types as H

21import Network.Wai

24import Network.Wai

22import Network.Wai.Handler.Warp.Request

25import Network.Wai.Handler.Warp.Request

23import Network.Wai.Handler.Warp.Response

26import Network.Wai.Handler.Warp.Response

@@ -233,7 +236,8 @@ serveConnection :: T.Handle

233 -> Cleaner

236 -> Cleaner

234 -> Port -> Application -> Connection -> SockAddr-> IO ()

237 -> Port -> Application -> Connection -> SockAddr-> IO ()

235serveConnection timeoutHandle settings cleaner port app conn remoteHost' =

238serveConnection timeoutHandle settings cleaner port app conn remoteHost' =

239+ respondOnException settings cleaner conn remoteHost' $

236− runResourceT serveConnection'

240+ runResourceT serveConnection'

237 where

241 where

238 innerRunResourceT

242 innerRunResourceT

239 | settingsResourceTPerRequest settings = lift . runResourceT

243 | settingsResourceTPerRequest settings = lift . runResourceT

@@ -265,6 +269,14 @@ serveConnection timeoutHandle settings cleaner port app conn remoteHost' =

265 ResumableSource fromClient' _ <- liftIO getSource

269 ResumableSource fromClient' _ <- liftIO getSource

266 intercept fromClient' conn

270 intercept fromClient' conn

267

271

272+respondOnException :: Settings -> Cleaner -> Connection -> SockAddr -> IO () -> IO ()

273+respondOnException settings cleaner conn remoteHost' io = io `catch` \e@(SomeException _) -> do

274+ _ <- runResourceT $ sendResponse settings cleaner blankRequest conn internalError

275+ throwIO e

276+ where

277+ blankRequest = Request H.methodGet H.http10 mempty mempty mempty 0 [] False remoteHost' [] [] (return mempty) mempty (KnownLength 0)

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

279+

268connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString

280connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString

269connSource Connection { connRecv = recv } th = src

281connSource Connection { connRecv = recv } th = src

270 where

282 where