@@ -89,6 +89,7 @@ import Control.Monad.Trans.Resource (ResourceT, runResourceT)
8989import qualified Data.Conduit as C
9090import qualified Data.Conduit.Binary as CB
9191import qualified Data.Conduit.List as CL
92+import Data.Conduit.Blaze (builderToByteString)
9293import Control.Exception.Lifted (throwIO)
9394import Blaze.ByteString.Builder.HTTP
9495 (chunkedTransferEncoding, chunkedTransferTerminator)
@@ -215,13 +216,13 @@ serveConnection settings th onException port app conn remoteHost' = do
215216 Nothing -> do
216217 -- Let the application run for as long as it wants
217218 liftIO $ T.pause th
218− res <- app env -- FIXME E.joinI $ EB.isolate len C.$$ app env
219+ res <- app env
219220 liftIO $ T.resume th
220− keepAlive <- liftIO $ sendResponse th env conn res
221+ keepAlive <- sendResponse th env conn res
221222 if keepAlive then serveConnection' else return ()
222− Just intercept -> error "intercept" {-do
223+ Just intercept -> do
223224 liftIO $ T.pause th
224− intercept conn-}
225+ intercept fromClient conn
225226
226227parseRequest :: Port -> SockAddr
227228 -> C.BSource IO S.ByteString
@@ -365,7 +366,7 @@ hasBody s req = s /= (H.Status 204 "") && s /= H.status304 &&
365366 H.statusCode s >= 200 && requestMethod req /= "HEAD"
366367
367368sendResponse :: T.Handle
368− -> Request -> Socket -> Response -> IO Bool
369+ -> Request -> Socket -> Response -> ResourceT IO Bool
369370sendResponse th req socket r = sendResponse' r
370371 where
371372 version = httpVersion req
@@ -375,8 +376,8 @@ sendResponse th req socket r = sendResponse' r
375376 isKeepAlive hs = isPersist && (isChunked' || hasLength hs)
376377 hasLength hs = lookup "content-length" hs /= Nothing
377378
378− sendResponse' :: Response -> IO Bool
379− sendResponse' (ResponseFile s hs fp mpart) = do
379+ sendResponse' :: Response -> ResourceT IO Bool
380+ sendResponse' (ResponseFile s hs fp mpart) = liftIO $ do
380381 (lengthyHeaders, cl) <-
381382 case (readInt `fmap` lookup "content-length" hs, mpart) of
382383 (Just cl, _) -> return (hs, cl)
@@ -405,12 +406,12 @@ sendResponse th req socket r = sendResponse' r
405406 addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)
406407
407408 sendResponse' (ResponseBuilder s hs b)
408− | hasBody s req = do
409+ | hasBody s req = liftIO $ do
409410 toByteStringIO (\bs -> do
410411 Sock.sendAll socket bs
411412 T.tickle th) body
412413 return (isKeepAlive hs)
413− | otherwise = do
414+ | otherwise = liftIO $ do
414415 Sock.sendMany socket
415416 $ L.toChunks
416417 $ toLazyByteString
@@ -426,32 +427,41 @@ sendResponse th req socket r = sendResponse' r
426427 `mappend` chunkedTransferTerminator
427428 else (headers' False) `mappend` b
428429
429− sendResponse' (ResponseStream res) = error "sendResponse'" {-res enumResponse
430+ sendResponse' (ResponseStream res) =
431+ res enumResponse
430432 where
431− enumResponse s hs = response True
433+ enumResponse :: H.Status -> H.ResponseHeaders -> C.SinkM Builder IO Bool
434+ enumResponse s hs =
435+ response
432436 where
433437 headers' = headers version s hs
434438 -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)
435− response _ | not (hasBody s req) = do
439+ response
440+ | not (hasBody s req) = do
436441 liftIO $ Sock.sendMany socket
437442 $ L.toChunks $ toLazyByteString
438443 $ headers' False
439444 return (checkPersist req)
440− response _ = chunk'
441− $ E.enumList 1 [headers' needsChunked']
442− $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString
443− $$ (iterSocket th socket >> return (isKeepAlive hs))
444− where
445− needsChunked' = needsChunked hs
446− chunk' i = if needsChunked'
447− then E.joinI $ chunk $$ i
448− else i
449− chunk :: E.Enumeratee Builder Builder IO Bool
450− chunk = E.checkDone $ E.continue . step
451− step k E.EOF = k (E.Chunks [chunkedTransferTerminator]) >>== return
452− step k (E.Chunks []) = E.continue $ step k
453− step k (E.Chunks [x]) = k (E.Chunks [chunkedTransferEncoding x]) >>== chunk
454− step k (E.Chunks xs) = k (E.Chunks [chunkedTransferEncoding $ mconcat xs]) >>== chunk -}
445+ | otherwise = C.SinkM $ do
446+ let sink = builderToByteString C.=$ sinkSocket th (isKeepAlive hs) socket
447+ CL.fromList [headers' needsChunked'] C.$$ sink
448+ C.genSink $ chunk' sink
449+ needsChunked' = needsChunked hs
450+ chunk' sink = if needsChunked'
451+ then chunk C.=$ sink
452+ else sink
453+ chunk :: C.ConduitM Builder IO Builder
454+ chunk = C.ConduitM $ return $ C.Conduit
455+ { C.conduitPush = push
456+ , C.conduitClose = close
457+ }
458+
459+ go [] = id
460+ go [x] = (chunkedTransferEncoding x:)
461+ go xs = (chunkedTransferEncoding (mconcat xs):)
462+
463+ push xs = return $ C.ConduitResult C.Processing $ go xs []
464+ close xs = return $ C.ConduitResult [] $ go xs [chunkedTransferTerminator]
455465
456466parseHeaderNoAttr :: ByteString -> H.Header
457467parseHeaderNoAttr s =
@@ -478,9 +488,10 @@ sourceSocket th len socket = C.Source
478488--separate package.
479489
480490sinkSocket :: T.Handle
491+ -> ret
481492 -> Socket
482− -> C.SinkM B.ByteString IO ()
483−sinkSocket th sock = C.SinkM $ return $ C.SinkData
493+ -> C.SinkM B.ByteString IO ret
494+sinkSocket th ret sock = C.SinkM $ return $ C.SinkData
484495 { C.sinkPush = push
485496 , C.sinkClose = close
486497 }
@@ -489,7 +500,7 @@ sinkSocket th sock = C.SinkM $ return $ C.SinkData
489500 liftIO (T.resume th)
490501 liftIO $ Sock.sendMany sock xs
491502 liftIO (T.resume th)
492− return (C.SinkResult [] ())
503+ return (C.SinkResult [] ret)
493504 push [] = return $ C.Processing
494505 push xs = do
495506 liftIO $ T.resume th
@@ -512,7 +523,7 @@ data Settings = Settings
512523 , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
513524 , settingsOnException :: 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.
514525 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
515− , settingsIntercept :: Request -> Maybe (Socket -> C.Sink S.ByteString IO ())
526+ , settingsIntercept :: Request -> Maybe (C.BSource IO S.ByteString -> Socket -> ResourceT IO ())
516527 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
517528 }
518529
@@ -579,7 +590,8 @@ takeHeaders' !len !lines !prepend !bs src = do
579590 if start < bsLen
580591 then {-# SCC "takeHeaders'.noMoreHeaders.yield" #-} do
581592 let !rest = {-# SCC "takeHeaders'.noMoreHeaders.yield.rest" #-} SU.unsafeDrop start bs
582− error "yield" -- E.yield lines' $! E.Chunks [rest]
593+ C.bsourceUnpull src [rest]
594+ return lines'
583595 else return lines'
584596
585597 -- more headers