211c75c · typeable/wai

git.iko.soy/typeable/wai

Make Responder a newtype to shield the quantifier

GHC likes to instantiate quantifiers as soon as possible, so it's hard to work with values whose types have exposed quantifiers. This makes Responders easier to manipulate and shuffle around, and adds some conveniences for implementing them in Identity, IO, and ContT r IO.

commit211c75cfafc0e7f8edd201ac2ee9f4829fe68f4f authorAndrew Pritchard <awpr@google.com> dateSat 5 Sep 2015, 15:38 (11 years ago) parent008c16e

3 files changed+70−42

compare with master

unifiedsplit

wai/Network/Wai/HTTP2.hs+59−24 wai/wai.cabal+1 warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+10−18

wai/Network/Wai/HTTP2.hs+59−24

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

2828 -- * Applications

2929 HTTP2Application

3030 -- * Responder

31− , Responder

31+ , Responder(..)

3232 , RespondFunc

3333 , Body

3434 , BodyOf

@@ -41,10 +41,13 @@ module Network.Wai.HTTP2

4141 -- * Conveniences

4242 , promoteApplication

4343 -- ** Responders

44− , responder

44+ , respond

45+ , respondCont

46+ , respondIO

4547 , respondFile

4648 , respondFilePart

4749 , respondNotFound

50+ , respondWith

4851 -- ** Stream Bodies

4952 , SimpleBody

5053 , streamFilePart

@@ -54,6 +57,7 @@ module Network.Wai.HTTP2

5457

5558import Blaze.ByteString.Builder (Builder)

5659import Control.Exception (Exception, SomeException, throwIO)

60+import Control.Monad.Trans.Cont (ContT(..))

5761import Data.ByteString (ByteString)

5862import Data.IORef (newIORef, readIORef, writeIORef)

5963#if __GLASGOW_HASKELL__ < 709

@@ -118,7 +122,8 @@ type RespondFunc s a = H.Status -> H.ResponseHeaders -> TrailerFunc a -> Body a

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

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

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

121−type Responder = forall s. (forall a. RespondFunc s a) -> IO s

125+newtype Responder = Responder

126+ { runResponder :: forall s. (forall a. RespondFunc s a) -> IO s }

122127

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

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

@@ -150,9 +155,9 @@ streamFilePart path part write _ = write $ FileChunk path part

150155-- If you want the range to be inferred automatically from the Range header,

151156-- use 'respondFile' instead.

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

153−respondFilePart s h path part respond = do

158+respondFilePart s h path part = Responder $ \k -> do

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

155− respond s' h' mempty $ streamFilePart path part

160+ k s' h' mempty $ streamFilePart path part

156161

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

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

@@ -161,11 +166,11 @@ respondFilePart s h path part respond = do

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

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

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

164−respondFile s h path reqHdrs respond = do

169+respondFile s h path reqHdrs = Responder $ \k -> do

165170 fileSize <- tryGetFileSize path

166171 case fileSize of

167− Left _ -> respondNotFound h respond

168− Right size -> respondFileExists s h path size reqHdrs respond

172+ Left _ -> runResponder (respondNotFound h) k

173+ Right size -> runResponder (respondFileExists s h path size reqHdrs) k

169174

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

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

@@ -174,12 +179,42 @@ respondFileExists s h path size reqHdrs =

174179

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

176181respondNotFound :: H.ResponseHeaders -> Responder

177−respondNotFound h respond = respond H.notFound404 h' mempty $

182+respondNotFound h = Responder $ \k -> k H.notFound404 h' mempty $

178183 streamBuilder "File not found."

179184 where

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

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

182187

188+-- | Construct a 'Responder' that will just call the 'RespondFunc' with the

189+-- given arguments.

190+respond :: H.Status -> H.ResponseHeaders -> TrailerFunc a -> Body a -> Responder

191+respond s h t b = Responder $ \k -> k s h t b

192+

193+-- | Fold the given bracketing action into a 'Responder'. Note the first

194+-- argument is isomorphic to @Codensity IO a@ or @forall s. ContT s IO a@, and

195+-- is the type of a partially-applied 'Control.Exception.bracket' or

196+-- @with@-style function.

197+--

198+-- > respondWith (bracket acquire release) $

199+-- > \x -> respondNotFound [("x", show x)]

200+--

201+-- is equivalent to

202+--

203+-- > Responder $ \k -> bracket acquire release $

204+-- > \x -> runResponder (respondNotFound [("x", show x)] k

205+--

206+-- This is morally equivalent to ('>>=') on 'Codensity' 'IO'.

207+respondWith :: (forall s. (a -> IO s) -> IO s) -> (a -> Responder) -> Responder

208+respondWith with f = respondCont $ f <$> ContT with

209+

210+-- | Fold the 'ContT' into the contained 'Responder'.

211+respondCont :: (forall r. ContT r IO Responder) -> Responder

212+respondCont cont = Responder $ \k -> runContT cont $ \r -> runResponder r k

213+

214+-- | Fold the 'IO' into the contained 'Responder'.

215+respondIO :: IO Responder -> Responder

216+respondIO io = Responder $ \k -> io >>= \r -> runResponder r k

217+

183218-- | Create a response body consisting of a single builder.

184219streamBuilder :: Builder -> Body ()

185220streamBuilder builder write _ = write $ BuilderChunk builder

@@ -198,17 +233,17 @@ streamSimple body write flush = body (write . BuilderChunk) flush

198233--

199234-- The 'Request' is used to determine the right file range to serve for

200235-- 'ResponseFile'.

201−responder :: Request -> Response -> Responder

202−responder req response respond = case response of

203− (ResponseBuilder s h b) -> respond s h mempty (streamBuilder b)

204− (ResponseStream s h body) -> respond s h mempty (streamSimple body)

205− (ResponseRaw _ fallback) -> responder req fallback respond

206− (ResponseFile s h path mpart) -> case mpart of

207− -- We can't use 'maybe' because the type checker can't instantiate the

208− -- type variable at 'Responder', which is a universally quantified

209− -- type.

210− Nothing -> respondFile s h path (requestHeaders req) respond

211− Just part -> respondFilePart s h path part respond

236+promoteResponse :: Request -> Response -> Responder

237+promoteResponse req response = case response of

238+ (ResponseBuilder s h b) ->

239+ Responder $ \k -> k s h mempty (streamBuilder b)

240+ (ResponseStream s h body) ->

241+ Responder $ \k -> k s h mempty (streamSimple body)

242+ (ResponseRaw _ fallback) -> promoteResponse req fallback

243+ (ResponseFile s h path mpart) -> maybe

244+ (respondFile s h path $ requestHeaders req)

245+ (respondFilePart s h path)

246+ mpart

212247

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

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

@@ -221,15 +256,15 @@ instance Exception RespondNeverCalled

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

222257-- the HTTP/2-specific features.

223258promoteApplication :: Application -> HTTP2Application

224−promoteApplication app req _ respond = do

259+promoteApplication app req _ = Responder $ \k -> do

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

226261 -- arbitrary type from the RespondFunc back to the caller of the

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

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

229264 -- in an IORef as a hack.

230265 ref <- newIORef Nothing

231− let respond' r = do

232− writeIORef ref . Just =<< responder req r respond

266+ let k' r = do

267+ writeIORef ref . Just =<< runResponder (promoteResponse req r) k

233268 return ResponseReceived

234− ResponseReceived <- app req respond'

269+ ResponseReceived <- app req k'

235270 readIORef ref >>= maybe (throwIO RespondNeverCalled) return

wai/wai.cabal+1

@@ -26,6 +26,7 @@ Library

2626 , network >= 2.2.1.5

2727 , http-types >= 0.7

2828 , text >= 0.7

29+ , transformers >= 0.0

2930 , unix-compat >= 0.2

3031 , vault >= 0.3 && < 0.4

3132 Exposed-modules: Network.Wai

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+10−18

@@ -31,7 +31,7 @@ import Network.Wai.HTTP2

3131 ( Chunk(..)

3232 , HTTP2Application

3333 , PushPromise

34− , Responder

34+ , Responder(runResponder)

3535 , RespondFunc

3636 )

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

@@ -48,14 +48,13 @@ import qualified Network.Wai.Handler.Warp.Timeout as T

4848-- doesn't break that property.

4949--

5050-- This is the argument to a 'Responder'.

51−type Respond = IO () -> Stream -> TBQueue Sequence

52− -> (forall a. RespondFunc () a)

51+type Respond = IO () -> Stream -> (forall a. RespondFunc () a)

5352

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

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

5655-- the HTTP/2 sender.

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

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

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

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

6059

6160 -- We must not exit this WAI application.

@@ -67,14 +66,17 @@ response ctx mgr tconf tickle strm sq s h trailers strmbdy = do

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

6867 setThreadContinue tconf False

6968

70− runStream ctx OResponse tickle strm sq s h trailers strmbdy

69+ runStream ctx OResponse tickle strm s h trailers strmbdy

7170

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

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

7473runStream :: Context

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

7675 -> Respond

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

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

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

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

79+ sq <- newTBQueueIO 10 -- fixme: hard coding: 10

7880 tvar <- newTVarIO SyncNone

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

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

@@ -94,16 +96,6 @@ runStream Context{outputQ} mkOutput tickle strm sq s h trailers strmbdy = do

9496 atomically $ writeTBQueue sq $ SFinish $ trailers x

9597 either throwIO (void . return) x

9698

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

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

99−-- 'runStream' for pushed streams.

100−runResponder :: Responder -> Respond -> IO () -> Stream -> IO ()

101−runResponder responder respond tickle strm = do

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

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

104− sq <- newTBQueueIO 10 -- fixme: hard coding: 10

105− responder $ respond tickle strm sq

106−

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

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

109101cleanupStream :: Context -> S.Settings -> Stream -> Maybe Request -> Maybe SomeException -> IO ()

@@ -165,7 +157,7 @@ actuallyPushResponder ctx set strm promise responder = do

165157 respond = runStream ctx mkOutput

166158

167159 -- TODO(awpr): synthesize a Request for 'settingsOnException'?

168− _ <- forkIO $ runResponder responder respond tickle newStrm `E.catch`

160+ _ <- forkIO $ runResponder responder (respond tickle newStrm) `E.catch`

169161 (cleanupStream ctx set strm Nothing . Just)

170162

171163 takeMVar mvar

@@ -197,7 +189,7 @@ worker ctx@Context{inputQ} set tm app respond = do

197189 T.resume th

198190 T.tickle th

199191 let responder = app req $ pushResponder ctx set strm

200− runResponder responder (respond tcont) (T.tickle th) strm

192+ runResponder responder $ respond tcont (T.tickle th) strm

201193 cont1 <- case ex of

202194 Right () -> return True

203195 Left e@(SomeException _)