178e0d9 · typeable/wai

git.iko.soy/typeable/wai

Force Responders to call the RespondFunc or raise

The HTTP/1 variant approximated this by using an "abstract" data type that only handlers should create, but now that wai's dependencies already use RankNTypes, it's safe to use them for real here. I've already messed up by calling the wrong RespondFunc a few times in HTTP2Applications using server push, so I'm now placing more weight on making the mistake manifest as a type error.

commit178e0d936864c39cf81cab050fe9569cf939aab1 authorAndrew Pritchard <awpr@google.com> dateTue 1 Sep 2015, 15:41 (11 years ago) parent72a860b

3 files changed+65−34

compare with master

unifiedsplit

wai/Network/Wai/HTTP2.hs+41−16 warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+23−14 warp/Network/Wai/Handler/Warp/Run.hs+1−4

wai/Network/Wai/HTTP2.hs+41−16

@@ -1,5 +1,6 @@

11{-# LANGUAGE OverloadedStrings, RankNTypes #-}

22{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DeriveDataTypeable #-}

45-- | An HTTP\/2-aware variant of the 'Network.Wai.Application' type. Compared

56-- to the original, this exposes the new functionality of server push and

@@ -28,6 +29,7 @@ module Network.Wai.HTTP2

2829 HTTP2Application

2930 -- * Responder

3031 , Responder

32+ , RespondFunc

3133 , Body

3234 , BodyOf

3335 , Chunk(..)

@@ -50,11 +52,12 @@ module Network.Wai.HTTP2

5052 , streamSimple

5153 ) where

5254

53−#if __GLASGOW_HASKELL__ < 710

54−import Data.Functor ((<$))

55−#endif

5655import Blaze.ByteString.Builder (Builder)

56+import Control.Exception (Exception, SomeException, throwIO)

5757import Data.ByteString (ByteString)

58+import Data.IORef (newIORef, readIORef, writeIORef)

59+import Data.Monoid (mempty)

60+import Data.Typeable (Typeable)

5861import qualified Network.HTTP.Types as H

5962

6063import Network.Wai (Application)

@@ -97,6 +100,14 @@ type Body a = BodyOf Chunk a

97100-- 'Network.Wai.StreamingBody' is identical to @BodyOf Builder ()@.

98101type BodyOf c a = (c -> IO ()) -> IO () -> IO a

99102

103+-- | Create trailers based on the result of a stream body.

104+type TrailerFunc a = Either SomeException a -> Trailers -- TODO IO?

105+

106+-- | Given to 'Responders'; provide a status, headers, a stream body, and a way

107+-- to produce trailers, and we'll give you a token proving you called the

108+-- 'RespondFunc'.

109+type RespondFunc s a = H.Status -> H.ResponseHeaders -> TrailerFunc a -> Body a -> IO s

110+

100111-- | The result of an 'HTTP2Application'; or, alternately, an application

101112-- that's independent of the request. This is a continuation-passing style

102113-- function that first provides a response by calling the given respond

@@ -105,8 +116,7 @@ type BodyOf c a = (c -> IO ()) -> IO () -> IO a

105116-- The respond function is similar to the one in 'Network.Wai.Application', but

106117-- it only takes a streaming body, the status and headers are curried, and it

107118-- passes on any result value from the stream body.

108−type Responder = (forall a. H.Status -> H.ResponseHeaders -> Body a -> IO a)

109− -> IO Trailers

119+type Responder = forall s. (forall a. RespondFunc s a) -> IO s

110120

111121-- | A function given to an 'HTTP2Application' to initiate a server-pushed

112122-- stream. Its argument is the same as the result of an 'HTTP2Application', so

@@ -140,8 +150,7 @@ streamFilePart path part write _ = write $ FileChunk path part

140150respondFilePart :: H.Status -> H.ResponseHeaders -> FilePath -> FilePart -> Responder

141151respondFilePart s h path part respond = do

142152 let (s', h') = adjustForFilePart s h part

143− respond s' h' $ streamFilePart path part

144− return []

153+ respond s' h' mempty $ streamFilePart path part

145154

146155-- | Serve the requested range of the specified file (based on the Range

147156-- header), using the given 'H.Status' and 'H.ResponseHeaders' as a base. If

@@ -150,11 +159,11 @@ respondFilePart s h path part respond = do

150159-- the status will be replaced with 206 and the Content-Range header will be

151160-- added. The Content-Length header will always be added.

152161respondFile :: H.Status -> H.ResponseHeaders -> FilePath -> H.RequestHeaders -> Responder

153−respondFile s h path req respond = do

162+respondFile s h path reqHdrs respond = do

154163 fileSize <- tryGetFileSize path

155164 case fileSize of

156165 Left _ -> respondNotFound h respond

157− Right size -> respondFileExists s h path size req respond

166+ Right size -> respondFileExists s h path size reqHdrs respond

158167

159168-- As 'respondFile', but with prior knowledge of the file's existence and size.

160169respondFileExists :: H.Status -> H.ResponseHeaders -> FilePath -> Integer -> H.RequestHeaders -> Responder

@@ -163,9 +172,8 @@ respondFileExists s h path size reqHdrs =

163172

164173-- | Respond with a minimal 404 page with the given headers.

165174respondNotFound :: H.ResponseHeaders -> Responder

166−respondNotFound h respond = do

167− respond H.notFound404 h' $ streamBuilder "File not found."

168− return []

175+respondNotFound h respond = respond H.notFound404 h' mempty $

176+ streamBuilder "File not found."

169177 where

170178 contentType = (H.hContentType, "text/plain; charset=utf-8")

171179 h' = contentType:filter ((/=H.hContentType) . fst) h

@@ -190,8 +198,8 @@ streamSimple body write flush = body (write . BuilderChunk) flush

190198-- 'ResponseFile'.

191199responder :: Request -> Response -> Responder

192200responder req response respond = case response of

193− (ResponseBuilder s h b) -> [] <$ respond s h (streamBuilder b)

194− (ResponseStream s h body) -> [] <$ respond s h (streamSimple body)

201+ (ResponseBuilder s h b) -> respond s h mempty (streamBuilder b)

202+ (ResponseStream s h body) -> respond s h mempty (streamSimple body)

195203 (ResponseRaw _ fallback) -> responder req fallback respond

196204 (ResponseFile s h path mpart) -> go respond

197205 where

@@ -202,8 +210,25 @@ responder req response respond = case response of

202210 (respondFilePart s h path)

203211 mpart

204212

213+-- | An 'Network.Wai.Application' we tried to promote neither called its

214+-- respond action nor raised; this is only possible if it imported the

215+-- 'ResponseReceived' and used it to lie about having called the action.

216+data RespondNeverCalled = RespondNeverCalled deriving (Show, Typeable)

217+

218+instance Exception RespondNeverCalled

219+

205220-- | Promote a normal WAI 'Application' to an 'HTTP2Application' by ignoring

206221-- the HTTP/2-specific features.

207222promoteApplication :: Application -> HTTP2Application

208−promoteApplication app req _ respond = [] <$ app req respond'

209− where respond' r = ResponseReceived <$ responder req r respond

223+promoteApplication app req _ respond = do

224+ -- In HTTP2Applications, the Responder is required to ferry a value of

225+ -- arbitrary type from the RespondFunc back to the caller of the

226+ -- application, but in Application the type is fixed to ResponseReceived.

227+ -- To add this extra power to an Application, we have to squirrel it away

228+ -- in an IORef as a hack.

229+ ref <- newIORef Nothing

230+ let respond' r = do

231+ writeIORef ref . Just =<< responder req r respond

232+ return ResponseReceived

233+ ResponseReceived <- app req respond'

234+ readIORef ref >>= maybe (throwIO RespondNeverCalled) return

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+23−14

@@ -33,24 +33,30 @@ import Network.Wai.HTTP2

3333 , HTTP2Application

3434 , PushPromise

3535 , Responder

36+ , RespondFunc

3637 )

3738import qualified Network.Wai.Handler.Warp.Settings as S

3839import qualified Network.Wai.Handler.Warp.Timeout as T

3940

4041----------------------------------------------------------------

4142

42−-- | An 'HTTP2Application' takes a function of status, headers, and body; this

43−-- type implements that by currying some internal arguments.

43+-- | An 'HTTP2Application' takes a function of status, headers, trailers, and

44+-- body; this type implements that by currying some internal arguments.

4445--

45−-- This is the argument to a 'Responder'.

46−type Respond = forall a. IO () -> Stream -> TBQueue Sequence

47− -> H.Status -> H.ResponseHeaders -> Body a -> IO a

46+-- The token type of the RespondFunc is set to be (). This is a bit

47+-- anti-climactic, but the real benefit of the token type is that the

48+-- application is forced to call the responder, and making it a boring type

49+-- doesn't break that property.

50+--

51+-- This is the argument to a 'Responder'.

52+type Respond = IO () -> Stream -> TBQueue Sequence

53+ -> (forall a. RespondFunc () a)

4854

49−-- | This function is passed to workers.

50−-- They also pass responses from 'HTTP2Application's to this function.

51−-- This function enqueues commands for the HTTP/2 sender.

55+-- | This function is passed to workers. They also pass responses from

56+-- 'HTTP2Application's to this function. This function enqueues commands for

57+-- the HTTP/2 sender.

5258response :: Context -> Manager -> ThreadContinue -> Respond

53−response ctx mgr tconf tickle strm sq s h strmbdy = do

59+response ctx mgr tconf tickle strm sq s h trailers strmbdy = do

5460 -- TODO(awpr) HEAD requests will still stream.

5561

5662 -- We must not exit this WAI application.

@@ -62,14 +68,14 @@ response ctx mgr tconf tickle strm sq s h strmbdy = do

6268 -- After this work, this thread stops to decrease the number of workers.

6369 setThreadContinue tconf False

6470

65− runStream ctx OResponse tickle strm sq s h strmbdy

71+ runStream ctx OResponse tickle strm sq s h trailers strmbdy

6672

6773-- | Set up a waiter thread and run the stream body with functions to enqueue

6874-- 'Sequence's on the stream's queue.

6975runStream :: Context

7076 -> (Stream -> H.Status -> H.ResponseHeaders -> Aux -> Output)

7177 -> Respond

72−runStream Context{outputQ} mkOutput tickle strm sq s h strmbdy = do

78+runStream Context{outputQ} mkOutput tickle strm sq s h trailers strmbdy = do

7379 tvar <- newTVarIO SyncNone

7480 let out = mkOutput strm s h (Persist sq tvar)

7581 -- Since we must not enqueue an empty queue to the priority

@@ -83,7 +89,11 @@ runStream Context{outputQ} mkOutput tickle strm sq s h strmbdy = do

8389 FileChunk path part -> SFile path part

8490 tickle

8591 flush = atomically $ writeTBQueue sq SFlush

86− strmbdy write flush

92+ -- Run the stream body, use its result to construct the trailers, and

93+ -- re-raise any Exception so it will still be handled later.

94+ x <- E.try $ strmbdy write flush

95+ atomically $ writeTBQueue sq $ SFinish $ trailers x

96+ either throwIO (void . return) x

8797

8898-- | Set up a queue for the stream and use the given 'Respond' to actually run

8999-- it. This will be 'response' for client-initiated streams and just plain

@@ -93,8 +103,7 @@ runResponder responder respond tickle strm = do

93103 -- Since 'Body' is loop, we cannot control it.

94104 -- So, let's serialize 'Builder' with a designated queue.

95105 sq <- newTBQueueIO 10 -- fixme: hard coding: 10

96− trailers <- responder $ respond tickle strm sq

97− atomically $ writeTBQueue sq $ SFinish trailers

106+ responder $ respond tickle strm sq

98107

99108-- | Handle abnormal termination of a stream: mark it as closed, send a reset

100109-- frame, and call the user's 'settingsOnException' handler if applicable.

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

@@ -6,9 +6,6 @@

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

9−#if __GLASGOW_HASKELL__ < 709

10−import Control.Applicative ((<*>))

11−#endif

129import Control.Arrow (first)

1310import Control.Concurrent (threadDelay)

1411import qualified Control.Concurrent as Conc (yield)

@@ -377,7 +374,7 @@ serveHTTP2Only = error "serveHTTP2Only not implemented"

377374

378375-- Serve an HTTP\/2-unaware Application to a connection over any HTTP version.

379376serveDefault :: Application -> ServeConnection

380−serveDefault = flip serveHTTP2 <*> promoteApplication

377+serveDefault app = serveHTTP2 (promoteApplication app) app

381378

382379-- Serve an HTTP\/2-aware application over HTTP\/2 or a backup 'Application'

383380-- over HTTP\/1.1 or HTTP\/1.