46357e5 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Implemented missing functionality in Warp

46357e5Michael Snoyman15 years ago

warp/Network/Wai/Handler/Warp.hs+44−32

compare with master

unifiedsplit

@@ -89,6 +89,7 @@ import Control.Monad.Trans.Resource (ResourceT, runResourceT)

89import qualified Data.Conduit as C

90import qualified Data.Conduit.Binary as CB

91import qualified Data.Conduit.List as CL

92+import Data.Conduit.Blaze (builderToByteString)

92import Control.Exception.Lifted (throwIO)

93import Control.Exception.Lifted (throwIO)

93import Blaze.ByteString.Builder.HTTP

94import Blaze.ByteString.Builder.HTTP

94 (chunkedTransferEncoding, chunkedTransferTerminator)

95 (chunkedTransferEncoding, chunkedTransferTerminator)

@@ -215,13 +216,13 @@ serveConnection settings th onException port app conn remoteHost' = do

215 Nothing -> do

216 Nothing -> do

216 -- Let the application run for as long as it wants

217 -- Let the application run for as long as it wants

217 liftIO $ T.pause th

218 liftIO $ T.pause th

218− res <- app env -- FIXME E.joinI $ EB.isolate len C.$$ app env

219+ res <- app env

219 liftIO $ T.resume th

220 liftIO $ T.resume th

220− keepAlive <- liftIO $ sendResponse th env conn res

221+ keepAlive <- sendResponse th env conn res

221 if keepAlive then serveConnection' else return ()

222 if keepAlive then serveConnection' else return ()

222− Just intercept -> error "intercept" {-do

223+ Just intercept -> do

223 liftIO $ T.pause th

224 liftIO $ T.pause th

224− intercept conn-}

225+ intercept fromClient conn

225

226

226parseRequest :: Port -> SockAddr

227parseRequest :: Port -> SockAddr

227 -> C.BSource IO S.ByteString

228 -> C.BSource IO S.ByteString

@@ -365,7 +366,7 @@ hasBody s req = s /= (H.Status 204 "") && s /= H.status304 &&

365 H.statusCode s >= 200 && requestMethod req /= "HEAD"

366 H.statusCode s >= 200 && requestMethod req /= "HEAD"

366

367

367sendResponse :: T.Handle

368sendResponse :: T.Handle

368− -> Request -> Socket -> Response -> IO Bool

369+ -> Request -> Socket -> Response -> ResourceT IO Bool

369sendResponse th req socket r = sendResponse' r

370sendResponse th req socket r = sendResponse' r

370 where

371 where

371 version = httpVersion req

372 version = httpVersion req

@@ -375,8 +376,8 @@ sendResponse th req socket r = sendResponse' r

375 isKeepAlive hs = isPersist && (isChunked' || hasLength hs)

376 isKeepAlive hs = isPersist && (isChunked' || hasLength hs)

376 hasLength hs = lookup "content-length" hs /= Nothing

377 hasLength hs = lookup "content-length" hs /= Nothing

377

378

378− sendResponse' :: Response -> IO Bool

379+ sendResponse' :: Response -> ResourceT IO Bool

379− sendResponse' (ResponseFile s hs fp mpart) = do

380+ sendResponse' (ResponseFile s hs fp mpart) = liftIO $ do

380 (lengthyHeaders, cl) <-

381 (lengthyHeaders, cl) <-

381 case (readInt `fmap` lookup "content-length" hs, mpart) of

382 case (readInt `fmap` lookup "content-length" hs, mpart) of

382 (Just cl, _) -> return (hs, cl)

383 (Just cl, _) -> return (hs, cl)

@@ -405,12 +406,12 @@ sendResponse th req socket r = sendResponse' r

405 addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)

406 addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)

406

407

407 sendResponse' (ResponseBuilder s hs b)

408 sendResponse' (ResponseBuilder s hs b)

408− | hasBody s req = do

409+ | hasBody s req = liftIO $ do

409 toByteStringIO (\bs -> do

410 toByteStringIO (\bs -> do

410 Sock.sendAll socket bs

411 Sock.sendAll socket bs

411 T.tickle th) body

412 T.tickle th) body

412 return (isKeepAlive hs)

413 return (isKeepAlive hs)

413− | otherwise = do

414+ | otherwise = liftIO $ do

414 Sock.sendMany socket

415 Sock.sendMany socket

415 $ L.toChunks

416 $ L.toChunks

416 $ toLazyByteString

417 $ toLazyByteString

@@ -426,32 +427,41 @@ sendResponse th req socket r = sendResponse' r

426 `mappend` chunkedTransferTerminator

427 `mappend` chunkedTransferTerminator

427 else (headers' False) `mappend` b

428 else (headers' False) `mappend` b

428

429

429− sendResponse' (ResponseStream res) = error "sendResponse'" {-res enumResponse

430+ sendResponse' (ResponseStream res) =

431+ res enumResponse

430 where

432 where

433+ enumResponse :: H.Status -> H.ResponseHeaders -> C.SinkM Builder IO Bool

434+ enumResponse s hs =

431− enumResponse s hs = response True

435+ response

432 where

436 where

433 headers' = headers version s hs

437 headers' = headers version s hs

434 -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)

438 -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)

439+ response

435− response _ | not (hasBody s req) = do

440+ | not (hasBody s req) = do

436 liftIO $ Sock.sendMany socket

441 liftIO $ Sock.sendMany socket

437 $ L.toChunks $ toLazyByteString

442 $ L.toChunks $ toLazyByteString

438 $ headers' False

443 $ headers' False

439 return (checkPersist req)

444 return (checkPersist req)

440− response _ = chunk'

445+ | otherwise = C.SinkM $ do

441− $ E.enumList 1 [headers' needsChunked']

446+ let sink = builderToByteString C.=$ sinkSocket th (isKeepAlive hs) socket

442− $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString

447+ CL.fromList [headers' needsChunked'] C.$$ sink

443− $$ (iterSocket th socket >> return (isKeepAlive hs))

448+ C.genSink $ chunk' sink

444− where

445− needsChunked' = needsChunked hs

449+ needsChunked' = needsChunked hs

446− chunk' i = if needsChunked'

450+ chunk' sink = if needsChunked'

447− then E.joinI $ chunk $$ i

451+ then chunk C.=$ sink

448− else i

452+ else sink

449− chunk :: E.Enumeratee Builder Builder IO Bool

453+ chunk :: C.ConduitM Builder IO Builder

450− chunk = E.checkDone $ E.continue . step

454+ chunk = C.ConduitM $ return $ C.Conduit

451− step k E.EOF = k (E.Chunks [chunkedTransferTerminator]) >>== return

455+ { C.conduitPush = push

452− step k (E.Chunks []) = E.continue $ step k

456+ , C.conduitClose = close

453− step k (E.Chunks [x]) = k (E.Chunks [chunkedTransferEncoding x]) >>== chunk

457+ }

454− step k (E.Chunks xs) = k (E.Chunks [chunkedTransferEncoding $ mconcat xs]) >>== chunk -}

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]

455

465

456parseHeaderNoAttr :: ByteString -> H.Header

466parseHeaderNoAttr :: ByteString -> H.Header

457parseHeaderNoAttr s =

467parseHeaderNoAttr s =

@@ -478,9 +488,10 @@ sourceSocket th len socket = C.Source

478--separate package.

488--separate package.

479

489

480sinkSocket :: T.Handle

490sinkSocket :: T.Handle

491+ -> ret

481 -> Socket

492 -> Socket

482− -> C.SinkM B.ByteString IO ()

493+ -> C.SinkM B.ByteString IO ret

483−sinkSocket th sock = C.SinkM $ return $ C.SinkData

494+sinkSocket th ret sock = C.SinkM $ return $ C.SinkData

484 { C.sinkPush = push

495 { C.sinkPush = push

485 , C.sinkClose = close

496 , C.sinkClose = close

486 }

497 }

@@ -489,7 +500,7 @@ sinkSocket th sock = C.SinkM $ return $ C.SinkData

489 liftIO (T.resume th)

500 liftIO (T.resume th)

490 liftIO $ Sock.sendMany sock xs

501 liftIO $ Sock.sendMany sock xs

491 liftIO (T.resume th)

502 liftIO (T.resume th)

492− return (C.SinkResult [] ())

503+ return (C.SinkResult [] ret)

493 push [] = return $ C.Processing

504 push [] = return $ C.Processing

494 push xs = do

505 push xs = do

495 liftIO $ T.resume th

506 liftIO $ T.resume th

@@ -512,7 +523,7 @@ data Settings = Settings

512 , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *

523 , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *

513 , 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.

524 , 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.

514 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30

525 , 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 ())

516 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'

527 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'

517 }

528 }

518

529

@@ -579,7 +590,8 @@ takeHeaders' !len !lines !prepend !bs src = do

579 if start < bsLen

590 if start < bsLen

580 then {-# SCC "takeHeaders'.noMoreHeaders.yield" #-} do

591 then {-# SCC "takeHeaders'.noMoreHeaders.yield" #-} do

581 let !rest = {-# SCC "takeHeaders'.noMoreHeaders.yield.rest" #-} SU.unsafeDrop start bs

592 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'

583 else return lines'

595 else return lines'

584

596

585 -- more headers

597 -- more headers