@@ -1,5 +1,6 @@
11{-# LANGUAGE OverloadedStrings, RankNTypes #-}
22{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
34
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
@@ -27,9 +28,9 @@ module Network.Wai.HTTP2
2728 -- * Applications
2829 HTTP2Application
2930 -- * Responder
30− , Responder
31+ , Responder(..)
32+ , RespondFunc
3133 , Body
32− , BodyOf
3334 , Chunk(..)
3435 , Trailers
3536 -- * Server push
@@ -39,22 +40,31 @@ module Network.Wai.HTTP2
3940 -- * Conveniences
4041 , promoteApplication
4142 -- ** Responders
42− , responder
43+ , respond
44+ , respondCont
45+ , respondIO
4346 , respondFile
4447 , respondFilePart
4548 , respondNotFound
49+ , respondWith
4650 -- ** Stream Bodies
47− , SimpleBody
4851 , streamFilePart
4952 , streamBuilder
5053 , streamSimple
5154 ) where
5255
53−#if __GLASGOW_HASKELL__ < 710
54−import Data.Functor ((<$))
55−#endif
5656import Blaze.ByteString.Builder (Builder)
57+import Control.Exception (Exception, throwIO)
58+import Control.Monad.Trans.Cont (ContT(..))
5759import Data.ByteString (ByteString)
60+#if __GLASGOW_HASKELL__ < 709
61+import Data.Functor ((<$>))
62+#endif
63+import Data.IORef (newIORef, readIORef, writeIORef)
64+#if __GLASGOW_HASKELL__ < 709
65+import Data.Monoid (mempty)
66+#endif
67+import Data.Typeable (Typeable)
5868import qualified Network.HTTP.Types as H
5969
6070import Network.Wai (Application)
@@ -63,6 +73,7 @@ import Network.Wai.Internal
6373 , Request(requestHeaders)
6474 , Response(..)
6575 , ResponseReceived(..)
76+ , StreamingBody
6677 , adjustForFilePart
6778 , chooseFilePart
6879 , tryGetFileSize
@@ -89,13 +100,12 @@ data Chunk = FileChunk FilePath FilePart | BuilderChunk Builder
89100
90101-- | The streaming body of a response. Equivalent to
91102-- 'Network.Wai.StreamingBody' except that it can also write file ranges and
92−-- return a result of type @a@.
93−type Body a = BodyOf Chunk a
103+-- return the stream's trailers.
104+type Body = (Chunk -> IO ()) -> IO () -> IO Trailers
94105
95−-- | Generalization of 'Body' to arbitrary chunk types.
96−--
97−-- 'Network.Wai.StreamingBody' is identical to @BodyOf Builder ()@.
98−type BodyOf c a = (c -> IO ()) -> IO () -> IO a
106+-- | Given to 'Responders'; provide a status, headers, and a stream body, and
107+-- we'll give you a token proving you called the 'RespondFunc'.
108+type RespondFunc s = H.Status -> H.ResponseHeaders -> Body -> IO s
99109
100110-- | The result of an 'HTTP2Application'; or, alternately, an application
101111-- that's independent of the request. This is a continuation-passing style
@@ -104,20 +114,30 @@ type BodyOf c a = (c -> IO ()) -> IO () -> IO a
104114--
105115-- The respond function is similar to the one in 'Network.Wai.Application', but
106116-- it only takes a streaming body, the status and headers are curried, and it
107−-- 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
117+-- also produces trailers for the stream.
118+newtype Responder = Responder
119+ { runResponder :: forall s. RespondFunc s -> 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
113123-- you can either implement the response inline, or call your own application
114124-- to create the response.
125+--
126+-- The result is 'True' if the @PUSH_PROMISE@ frame will be sent, or 'False' if
127+-- it will not. This can happen if server push is disabled, the concurrency
128+-- limit of server-initiated streams is reached, or the associated stream has
129+-- already been closed.
130+--
131+-- This function shall ensure that stream data provided after it returns will
132+-- be sent after the @PUSH_PROMISE@ frame, so that servers can implement the
133+-- requirement that any pushed stream for a resource be initiated before
134+-- sending DATA frames that reference it.
115135type PushFunc = PushPromise -> Responder -> IO Bool
116136
117137-- | Create the 'H.RequestHeaders' corresponding to the given 'PushPromise'.
118138--
119−-- This is primarily useful for Wai handlers like Warp, and application
120−-- implementers are unlikely to need it.
139+-- This is primarily useful for WAI handlers like Warp, and application
140+-- implementers are unlikely to use it directly.
121141promiseHeaders :: PushPromise -> H.RequestHeaders
122142promiseHeaders p =
123143 [ (":method", promisedMethod p)
@@ -129,19 +149,21 @@ promiseHeaders p =
129149-- | Create a response body consisting of a single range of a file. Does not
130150-- set Content-Length or Content-Range headers. For that, use
131151-- 'respondFilePart' or 'respondFile'.
132−streamFilePart :: FilePath -> FilePart -> Body ()
133−streamFilePart path part write _ = write $ FileChunk path part
152+streamFilePart :: FilePath -> FilePart -> Body
153+streamFilePart path part write _ = write (FileChunk path part) >> return []
134154
135−-- | Respond with a single range of a file, adding the Content-Length and
136−-- Content-Range headers and changing the status to 206 as appropriate.
155+-- | Respond with a single range of a file, adding the Accept-Ranges,
156+-- Content-Length and Content-Range headers and changing the status to 206 as
157+-- appropriate.
137158--
138159-- If you want the range to be inferred automatically from the Range header,
139−-- use 'respondFile' instead.
160+-- use 'respondFile' instead. On the other hand, if you want to avoid the
161+-- automatic header and status adjustments, use 'respond' and 'streamFilePart'
162+-- directly.
140163respondFilePart :: H.Status -> H.ResponseHeaders -> FilePath -> FilePart -> Responder
141−respondFilePart s h path part respond = do
164+respondFilePart s h path part = Responder $ \k -> do
142165 let (s', h') = adjustForFilePart s h part
143− respond s' h' $ streamFilePart path part
144− return []
166+ k s' h' $ streamFilePart path part
145167
146168-- | Serve the requested range of the specified file (based on the Range
147169-- header), using the given 'H.Status' and 'H.ResponseHeaders' as a base. If
@@ -150,11 +172,11 @@ respondFilePart s h path part respond = do
150172-- the status will be replaced with 206 and the Content-Range header will be
151173-- added. The Content-Length header will always be added.
152174respondFile :: H.Status -> H.ResponseHeaders -> FilePath -> H.RequestHeaders -> Responder
153−respondFile s h path req respond = do
175+respondFile s h path reqHdrs = Responder $ \k -> do
154176 fileSize <- tryGetFileSize path
155177 case fileSize of
156− Left _ -> respondNotFound h respond
157− Right size -> respondFileExists s h path size req respond
178+ Left _ -> runResponder (respondNotFound h) k
179+ Right size -> runResponder (respondFileExists s h path size reqHdrs) k
158180
159181-- As 'respondFile', but with prior knowledge of the file's existence and size.
160182respondFileExists :: H.Status -> H.ResponseHeaders -> FilePath -> Integer -> H.RequestHeaders -> Responder
@@ -163,47 +185,87 @@ respondFileExists s h path size reqHdrs =
163185
164186-- | Respond with a minimal 404 page with the given headers.
165187respondNotFound :: H.ResponseHeaders -> Responder
166−respondNotFound h respond = do
167− respond H.notFound404 h' $ streamBuilder "File not found."
168− return []
188+respondNotFound h = Responder $ \k -> k H.notFound404 h' $
189+ streamBuilder "File not found."
169190 where
170191 contentType = (H.hContentType, "text/plain; charset=utf-8")
171192 h' = contentType:filter ((/=H.hContentType) . fst) h
172193
173−-- | Create a response body consisting of a single builder.
174−streamBuilder :: Builder -> Body ()
175−streamBuilder builder write _ = write $ BuilderChunk builder
194+-- | Construct a 'Responder' that will just call the 'RespondFunc' with the
195+-- given arguments.
196+respond :: H.Status -> H.ResponseHeaders -> Body -> Responder
197+respond s h b = Responder $ \k -> k s h b
176198
177−-- | Equivalent to 'Body' but only streaming 'Builder's.
199+-- | Fold the given bracketing action into a 'Responder'. Note the first
200+-- argument is isomorphic to @Codensity IO a@ or @forall s. ContT s IO a@, and
201+-- is the type of a partially-applied 'Control.Exception.bracket' or
202+-- @with@-style function.
203+--
204+-- > respondWith (bracket acquire release) $
205+-- > \x -> respondNotFound [("x", show x)]
178206--
179−-- 'Network.Wai.StreamingBody' is identical to @SimpleBody ()@.
180−type SimpleBody a = BodyOf Builder a
207+-- is equivalent to
208+--
209+-- > Responder $ \k -> bracket acquire release $
210+-- > \x -> runResponder (respondNotFound [("x", show x)] k
211+--
212+-- This is morally equivalent to ('>>=') on 'Codensity' 'IO'.
213+respondWith :: (forall s. (a -> IO s) -> IO s) -> (a -> Responder) -> Responder
214+respondWith with f = respondCont $ f <$> ContT with
215+
216+-- | Fold the 'ContT' into the contained 'Responder'.
217+respondCont :: (forall r. ContT r IO Responder) -> Responder
218+respondCont cont = Responder $ \k -> runContT cont $ \r -> runResponder r k
219+
220+-- | Fold the 'IO' into the contained 'Responder'.
221+respondIO :: IO Responder -> Responder
222+respondIO io = Responder $ \k -> io >>= \r -> runResponder r k
223+
224+-- | Create a response body consisting of a single builder.
225+streamBuilder :: Builder -> Body
226+streamBuilder builder write _ = write (BuilderChunk builder) >> return []
181227
182228-- | Create a response body of a stream of 'Builder's.
183−streamSimple :: SimpleBody a -> Body a
184−streamSimple body write flush = body (write . BuilderChunk) flush
229+streamSimple :: StreamingBody -> Body
230+streamSimple body write flush = body (write . BuilderChunk) flush >> return []
185231
186232-- | Use a normal WAI 'Response' to send the response. Useful if you're
187233-- sharing code between HTTP\/2 applications and HTTP\/1 applications.
188234--
189235-- The 'Request' is used to determine the right file range to serve for
190236-- 'ResponseFile'.
191−responder :: Request -> Response -> Responder
192−responder 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)
195− (ResponseRaw _ fallback) -> responder req fallback respond
196− (ResponseFile s h path mpart) -> go respond
197− where
198− -- Hooray, forcing things to be universally quantified.
199− go :: Responder
200− go = maybe
201− (respondFile s h path $ requestHeaders req)
202− (respondFilePart s h path)
203− mpart
237+promoteResponse :: Request -> Response -> Responder
238+promoteResponse req response = case response of
239+ (ResponseBuilder s h b) ->
240+ Responder $ \k -> k s h (streamBuilder b)
241+ (ResponseStream s h body) ->
242+ Responder $ \k -> k s h (streamSimple body)
243+ (ResponseRaw _ fallback) -> promoteResponse req fallback
244+ (ResponseFile s h path mpart) -> maybe
245+ (respondFile s h path $ requestHeaders req)
246+ (respondFilePart s h path)
247+ mpart
248+
249+-- | An 'Network.Wai.Application' we tried to promote neither called its
250+-- respond action nor raised; this is only possible if it imported the
251+-- 'ResponseReceived' constructor and used it to lie about having called the
252+-- action.
253+data RespondNeverCalled = RespondNeverCalled deriving (Show, Typeable)
254+
255+instance Exception RespondNeverCalled
204256
205257-- | Promote a normal WAI 'Application' to an 'HTTP2Application' by ignoring
206258-- the HTTP/2-specific features.
207259promoteApplication :: Application -> HTTP2Application
208−promoteApplication app req _ respond = [] <$ app req respond'
209− where respond' r = ResponseReceived <$ responder req r respond
260+promoteApplication app req _ = Responder $ \k -> do
261+ -- In HTTP2Applications, the Responder is required to ferry a value of
262+ -- arbitrary type from the RespondFunc back to the caller of the
263+ -- application, but in Application the type is fixed to ResponseReceived.
264+ -- To add this extra power to an Application, we have to squirrel it away
265+ -- in an IORef as a hack.
266+ ref <- newIORef Nothing
267+ let k' r = do
268+ writeIORef ref . Just =<< runResponder (promoteResponse req r) k
269+ return ResponseReceived
270+ ResponseReceived <- app req k'
271+ readIORef ref >>= maybe (throwIO RespondNeverCalled) return