360442a · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Began moving wai/warp to conduit

360442aMichael15 years ago

conduit/Data/Conduit.hs+17−4

compare with master

unifiedsplit

@@ -1,4 +1,7 @@

1{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE UndecidableInstances #-}

2{-# LANGUAGE DeriveDataTypeable #-}

5{-# LANGUAGE DeriveDataTypeable #-}

3module Data.Conduit

6module Data.Conduit

4 ( -- * Helper types

7 ( -- * Helper types

@@ -19,7 +22,8 @@ module Data.Conduit

20import Control.Monad.Trans.Resource

23import Control.Monad.Trans.Resource

21import Control.Monad.Trans.Control (MonadBaseControl)

24import Control.Monad.Trans.Control (MonadBaseControl)

22−import Control.Monad.Base (liftBase)

25+import Control.Monad.Trans.Class (MonadTrans (lift))

26+import Control.Monad.Base (MonadBase (liftBase))

23import Control.Exception.Lifted (throwIO, Exception)

27import Control.Exception.Lifted (throwIO, Exception)

24import qualified Data.IORef as I

28import qualified Data.IORef as I

25import Data.Typeable (Typeable)

29import Data.Typeable (Typeable)

@@ -53,15 +57,16 @@ instance Monad m => Functor (Sink input m) where

53instance MonadBaseControl IO m => Applicative (Sink input m) where

57instance MonadBaseControl IO m => Applicative (Sink input m) where

54 pure x =

58 pure x =

55 Sink (return (\s -> return (SinkResult (toList s) (Just x))))

59 Sink (return (\s -> return (SinkResult (toList s) (Just x))))

56− where

57− toList EOF = []

58− toList (Chunks a) = a

59 Sink mf <*> Sink ma = Sink $ do

60 Sink mf <*> Sink ma = Sink $ do

60 istate <- liftBase $ I.newIORef Nothing

61 istate <- liftBase $ I.newIORef Nothing

61 f <- mf

62 f <- mf

62 a <- ma

63 a <- ma

63 return $ appHelper istate f a

64 return $ appHelper istate f a

66+toList :: Stream a -> [a]

67+toList EOF = []

68+toList (Chunks a) = a

69+

65appHelper :: MonadBaseControl IO m

70appHelper :: MonadBaseControl IO m

66 => I.IORef (Maybe (Either (b -> c) ()))

71 => I.IORef (Maybe (Either (b -> c) ()))

67 -> SinkInside a m (b -> c)

72 -> SinkInside a m (b -> c)

@@ -86,6 +91,14 @@ instance MonadBaseControl IO m => Monad (Sink input m) where

86 return = pure

91 return = pure

87 x >>= f = sinkJoin (fmap f x)

92 x >>= f = sinkJoin (fmap f x)

94+instance MonadBaseControl IO m => MonadBase IO (Sink input m) where

95+ liftBase = lift . liftBase

96+

97+instance MonadTrans (Sink input) where

98+ lift f = Sink $ do

99+ x <- lift f

100+ return $ \s -> return (SinkResult (toList s) (Just x))

101+

89sinkJoin :: MonadBaseControl IO m => Sink a m (Sink a m b) -> Sink a m b

102sinkJoin :: MonadBaseControl IO m => Sink a m (Sink a m b) -> Sink a m b

90sinkJoin (Sink mmsink) = Sink $ do

103sinkJoin (Sink mmsink) = Sink $ do

91 istate <- liftBase $ I.newIORef Nothing

104 istate <- liftBase $ I.newIORef Nothing

wai/Network/Wai.hs+12−9

@@ -51,11 +51,9 @@ module Network.Wai

51import qualified Data.ByteString as B

52import qualified Data.ByteString.Lazy as L

53import Data.Typeable (Typeable)

54−import Data.Enumerator (Enumerator, Iteratee (..), ($$), joinI, run_)

54+import Control.Monad.Trans.Resource (ResourceT)

55−import qualified Data.Enumerator as E

55+import qualified Data.Conduit as C

56−import qualified Data.Enumerator.List as EL

57−import Data.Enumerator.Binary (enumFile, enumFileRange)

58−import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)

56+import Blaze.ByteString.Builder (Builder, fromLazyByteString)

59import Network.Socket (SockAddr)

57import Network.Socket (SockAddr)

60import qualified Network.HTTP.Types as H

58import qualified Network.HTTP.Types as H

61import Data.Text (Text)

59import Data.Text (Text)

@@ -94,8 +92,9 @@ data Request = Request

94 , pathInfo :: [Text]

92 , pathInfo :: [Text]

95 -- | Parsed query string information

93 -- | Parsed query string information

96 , queryString :: H.Query

94 , queryString :: H.Query

95+ , requestBody :: C.Source IO B.ByteString

97 }

96 }

98− deriving (Show, Typeable)

97+ deriving (Typeable)

100data Response

99data Response

101 = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)

100 = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)

@@ -133,9 +132,12 @@ data FilePart = FilePart

133-- optimal size by sending a flush command.

132-- optimal size by sending a flush command.

134

133

135type ResponseEnumerator a =

134type ResponseEnumerator a =

136− (H.Status -> H.ResponseHeaders -> Iteratee Builder IO a) -> IO a

135+ (H.Status -> H.ResponseHeaders -> C.Sink Builder IO a)

136+ -> ResourceT IO a

137

138responseEnumerator :: Response -> ResponseEnumerator a

139+responseEnumerator = undefined

140+{-

139responseEnumerator (ResponseEnumerator e) f = e f

141responseEnumerator (ResponseEnumerator e) f = e f

140responseEnumerator (ResponseFile s h fp mpart) f =

142responseEnumerator (ResponseFile s h fp mpart) f =

141 run_ $ (maybe enumFile enumFilePart) mpart fp $$ joinI

143 run_ $ (maybe enumFile enumFilePart) mpart fp $$ joinI

@@ -144,14 +146,15 @@ responseEnumerator (ResponseBuilder s h b) f = run_ $ do

144 E.yield () $ E.Chunks [b]

146 E.yield () $ E.Chunks [b]

145 f s h

147 f s h

146

148

147−enumFilePart :: FilePart -> FilePath -> Enumerator B.ByteString IO a

149+enumFilePart :: FilePart -> FilePath -> C.Source IO B.ByteString

148enumFilePart (FilePart offset count) fp =

150enumFilePart (FilePart offset count) fp =

149 enumFileRange fp (Just offset) (Just count)

151 enumFileRange fp (Just offset) (Just count)

152+-}

150

153

151responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

154responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

152responseLBS s h = ResponseBuilder s h . fromLazyByteString

155responseLBS s h = ResponseBuilder s h . fromLazyByteString

153

156

154−type Application = Request -> Iteratee B.ByteString IO Response

157+type Application = Request -> ResourceT IO Response

155

158

156-- | Middleware is a component that sits between the server and application. It

159-- | Middleware is a component that sits between the server and application. It

157-- can do such tasks as GZIP encoding or response caching. What follows is the

160-- can do such tasks as GZIP encoding or response caching. What follows is the

wai/wai.cabal+2−2

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

1Name: wai

2−Version: 0.4.3

2+Version: 0.5.0

3Synopsis: Web Application Interface.

4Description: Provides a common protocol for communication between web applications and web servers.

5License: BSD3

@@ -20,7 +20,7 @@ Library

20 Build-Depends: base >= 4 && < 5

21 , bytestring >= 0.9.1.4 && < 0.10

22 , blaze-builder >= 0.2.1.4 && < 0.4

23− , enumerator >= 0.4.8 && < 0.5

23+ , conduit >= 0.0 && < 0.1

24 , network >= 2.2.1.5 && < 2.4

25 , http-types >= 0.6 && < 0.7

26 , text >= 0.7 && < 0.12

warp/Network/Wai/Handler/Warp.hs+45−48

@@ -46,7 +46,6 @@ module Network.Wai.Handler.Warp

46 , sendResponse

47 , registerKillThread

48 , bindPort

49− , enumSocket

50 , pause

49 , pause

51 , resume

50 , resume

52 , T.cancel

51 , T.cancel

@@ -86,11 +85,10 @@ import Data.Maybe (fromMaybe)

87import Data.Typeable (Typeable)

86import Data.Typeable (Typeable)

89−import Data.Enumerator (($$), (>>==))

88+import Control.Monad.Trans.Resource (ResourceT, runResourceT)

90−import qualified Data.Enumerator as E

89+import qualified Data.Conduit as C

91−import qualified Data.Enumerator.List as EL

90+import qualified Data.Conduit.List as CL

92−import qualified Data.Enumerator.Binary as EB

91+import Control.Exception.Lifted (throwIO)

93−import Blaze.ByteString.Builder.Enumerator (builderToByteString)

94import Blaze.ByteString.Builder.HTTP

92import Blaze.ByteString.Builder.HTTP

95 (chunkedTransferEncoding, chunkedTransferTerminator)

93 (chunkedTransferEncoding, chunkedTransferTerminator)

96import Blaze.ByteString.Builder

94import Blaze.ByteString.Builder

@@ -204,26 +202,27 @@ serveConnection :: Settings

204serveConnection settings th onException port app conn remoteHost' = do

202serveConnection settings th onException port app conn remoteHost' = do

205 catch

203 catch

206 (finally

204 (finally

207− (E.run_ $ fromClient $$ serveConnection')

205+ (runResourceT serveConnection')

208 (sClose conn))

206 (sClose conn))

209 onException

207 onException

210 where

208 where

211− fromClient = enumSocket th bytesPerRead conn

209+ fromClient = sourceSocket th bytesPerRead conn

210+ serveConnection' :: ResourceT IO ()

212 serveConnection' = do

211 serveConnection' = do

213− (len, env) <- parseRequest port remoteHost'

212+ (len, env) <- fromClient C.$$ parseRequest port remoteHost'

214 case settingsIntercept settings env of

213 case settingsIntercept settings env of

215 Nothing -> do

214 Nothing -> do

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

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

217 liftIO $ T.pause th

216 liftIO $ T.pause th

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

217+ res <- app env -- FIXME E.joinI $ EB.isolate len C.$$ app env

219 liftIO $ T.resume th

218 liftIO $ T.resume th

220 keepAlive <- liftIO $ sendResponse th env conn res

219 keepAlive <- liftIO $ sendResponse th env conn res

221 if keepAlive then serveConnection' else return ()

220 if keepAlive then serveConnection' else return ()

222− Just intercept -> do

221+ Just intercept -> undefined {-do

223 liftIO $ T.pause th

222 liftIO $ T.pause th

224− intercept conn

223+ intercept conn-}

225

224

226−parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request)

225+parseRequest :: Port -> SockAddr -> C.Sink S.ByteString IO (Integer, Request)

227parseRequest port remoteHost' = do

226parseRequest port remoteHost' = do

228 headers' <- takeHeaders

227 headers' <- takeHeaders

229 parseRequest' port headers' remoteHost'

228 parseRequest' port headers' remoteHost'

@@ -247,8 +246,8 @@ instance Exception InvalidRequest

247parseRequest' :: Port

246parseRequest' :: Port

248 -> [ByteString]

247 -> [ByteString]

249 -> SockAddr

248 -> SockAddr

250− -> E.Iteratee S.ByteString IO (Integer, Request)

249+ -> C.Sink S.ByteString IO (Integer, Request)

251−parseRequest' _ [] _ = E.throwError $ NotEnoughLines []

250+parseRequest' _ [] _ = throwIO $ NotEnoughLines []

252parseRequest' port (firstLine:otherLines) remoteHost' = do

251parseRequest' port (firstLine:otherLines) remoteHost' = do

253 (method, rpath', gets, httpversion) <- parseFirst firstLine

252 (method, rpath', gets, httpversion) <- parseFirst firstLine

254 let (host',rpath) =

253 let (host',rpath) =

@@ -289,7 +288,7 @@ takeUntil c bs =

289{-# INLINE takeUntil #-}

288{-# INLINE takeUntil #-}

290

289

291parseFirst :: ByteString

290parseFirst :: ByteString

292− -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, H.HttpVersion)

291+ -> C.Sink S.ByteString IO (ByteString, ByteString, ByteString, H.HttpVersion)

293parseFirst s =

292parseFirst s =

294 case S.split 32 s of -- ' '

293 case S.split 32 s of -- ' '

295 [method, query, http'] -> do

294 [method, query, http'] -> do

@@ -301,8 +300,8 @@ parseFirst s =

301 "1.1" -> H.http11

300 "1.1" -> H.http11

302 _ -> H.http10

301 _ -> H.http10

303 in return (method, rpath, qstring, hv)

302 in return (method, rpath, qstring, hv)

304− else E.throwError NonHttp

303+ else throwIO NonHttp

305− _ -> E.throwError $ BadFirstLine $ B.unpack s

304+ _ -> throwIO $ BadFirstLine $ B.unpack s

306{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported

305{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported

307

306

308httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder

307httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder

@@ -421,7 +420,7 @@ sendResponse th req socket r = sendResponse' r

421 `mappend` chunkedTransferTerminator

420 `mappend` chunkedTransferTerminator

422 else (headers' False) `mappend` b

421 else (headers' False) `mappend` b

423

422

424− sendResponse' (ResponseEnumerator res) = res enumResponse

423+ sendResponse' (ResponseEnumerator res) = undefined {-res enumResponse

425 where

424 where

426 enumResponse s hs = response True

425 enumResponse s hs = response True

427 where

426 where

@@ -446,7 +445,7 @@ sendResponse th req socket r = sendResponse' r

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

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

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

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

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

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

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

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

450

449

451parseHeaderNoAttr :: ByteString -> H.Header

450parseHeaderNoAttr :: ByteString -> H.Header

452parseHeaderNoAttr s =

451parseHeaderNoAttr s =

@@ -458,37 +457,32 @@ parseHeaderNoAttr s =

458 else rest

457 else rest

459 in (CI.mk k, rest')

458 in (CI.mk k, rest')

460

459

461−enumSocket :: T.Handle -> Int -> Socket -> E.Enumerator ByteString IO a

460+sourceSocket :: T.Handle -> Int -> Socket -> C.Source IO ByteString

462−enumSocket th len socket =

461+sourceSocket th len socket = C.mkSource $ do

463− inner

464− where

465− inner (E.Continue k) = do

466− bs <- liftIO $ Sock.recv socket len

462+ bs <- liftIO $ Sock.recv socket len

467− liftIO $ T.tickle th

463+ liftIO $ T.tickle th

468− if S.null bs

469− then E.continue k

470− else k (E.Chunks [bs]) >>== inner

464+ return $ if S.null bs then C.EOF else C.Chunks [bs]

471− inner step = E.returnI step

465+

472------ The functions below are not warp-specific and could be split out into a

466------ The functions below are not warp-specific and could be split out into a

473--separate package.

467--separate package.

474

468

475−iterSocket :: T.Handle

469+sinkSocket :: T.Handle

476 -> Socket

470 -> Socket

477− -> E.Iteratee B.ByteString IO ()

471+ -> C.Sink B.ByteString IO ()

478−iterSocket th sock =

472+sinkSocket th sock =

479− E.continue step

473+ C.Sink $ return go

480 where

474 where

475+ go C.EOF = liftIO (T.resume th) >> return (C.SinkResult [] (Just ()))

476+ go (C.Chunks []) = return $ C.SinkResult [] Nothing

477+ go (C.Chunks xs) = do

478+ liftIO $ T.resume th

479+ liftIO $ Sock.sendMany sock xs

480+ liftIO $ T.pause th

481+ return $ C.SinkResult [] Nothing

481 -- We pause timeouts before passing control back to user code. This ensures

482 -- We pause timeouts before passing control back to user code. This ensures

482 -- that a timeout will only ever be executed when Warp is in control. We

483 -- that a timeout will only ever be executed when Warp is in control. We

483 -- also make sure to resume the timeout after the completion of user code

484 -- also make sure to resume the timeout after the completion of user code

484 -- so that we can kill idle connections.

485 -- so that we can kill idle connections.

485− step E.EOF = liftIO (T.resume th) >> E.yield () E.EOF

486− step (E.Chunks []) = E.continue step

487− step (E.Chunks xs) = do

488− liftIO $ T.resume th

489− liftIO $ Sock.sendMany sock xs

490− liftIO $ T.pause th

491− E.continue step

492

486

493-- | Various Warp server settings. This is purposely kept as an abstract data

487-- | Various Warp server settings. This is purposely kept as an abstract data

494-- type so that new settings can be added without breaking backwards

488-- type so that new settings can be added without breaking backwards

@@ -501,7 +495,7 @@ data Settings = Settings

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

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

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

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

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

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

504− , settingsIntercept :: Request -> Maybe (Socket -> E.Iteratee S.ByteString IO ())

498+ , settingsIntercept :: Request -> Maybe (Socket -> C.Sink S.ByteString IO ())

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

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

506 }

500 }

507

501

@@ -528,7 +522,7 @@ defaultSettings = Settings

528 go' (Just ThreadKilled) = False

522 go' (Just ThreadKilled) = False

529 go' _ = True

523 go' _ = True

530

524

531−takeHeaders :: E.Iteratee ByteString IO [ByteString]

525+takeHeaders :: C.Sink ByteString IO [ByteString]

532takeHeaders = do

526takeHeaders = do

533 !x <- forceHead ConnectionClosedByPeer

527 !x <- forceHead ConnectionClosedByPeer

534 takeHeaders' 0 id id x

528 takeHeaders' 0 id id x

@@ -539,8 +533,8 @@ takeHeaders' :: Int

539 -> ([ByteString] -> [ByteString])

533 -> ([ByteString] -> [ByteString])

540 -> ([ByteString] -> [ByteString])

534 -> ([ByteString] -> [ByteString])

541 -> ByteString

535 -> ByteString

542− -> E.Iteratee S.ByteString IO [ByteString]

536+ -> C.Sink S.ByteString IO [ByteString]

543−takeHeaders' !len _ _ _ | len > maxTotalHeaderLength = E.throwError OverLargeHeader

537+takeHeaders' !len _ _ _ | len > maxTotalHeaderLength = throwIO OverLargeHeader

544takeHeaders' !len !lines !prepend !bs = do

538takeHeaders' !len !lines !prepend !bs = do

545 let !bsLen = {-# SCC "takeHeaders'.bsLen" #-} S.length bs

539 let !bsLen = {-# SCC "takeHeaders'.bsLen" #-} S.length bs

546 !mnl = {-# SCC "takeHeaders'.mnl" #-} S.elemIndex 10 bs

540 !mnl = {-# SCC "takeHeaders'.mnl" #-} S.elemIndex 10 bs

@@ -567,7 +561,7 @@ takeHeaders' !len !lines !prepend !bs = do

567 if start < bsLen

561 if start < bsLen

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

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

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

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

570− E.yield lines' $! E.Chunks [rest]

564+ undefined -- E.yield lines' $! E.Chunks [rest]

571 else return lines'

565 else return lines'

572

566

573 -- more headers

567 -- more headers

@@ -581,12 +575,15 @@ takeHeaders' !len !lines !prepend !bs = do

581 {-# SCC "takeHeaders'.takeMore" #-} takeHeaders' len' lines' id more

575 {-# SCC "takeHeaders'.takeMore" #-} takeHeaders' len' lines' id more

582{-# INLINE takeHeaders' #-}

576{-# INLINE takeHeaders' #-}

583

577

584−forceHead :: InvalidRequest -> E.Iteratee ByteString IO ByteString

578+forceHead :: InvalidRequest -> C.Sink ByteString IO ByteString

585forceHead err = do

579forceHead err = do

580+ undefined

581+ {-

586 !mx <- EL.head

582 !mx <- EL.head

587 case mx of

583 case mx of

588 !Nothing -> E.throwError err

584 !Nothing -> E.throwError err

589 Just !x -> return x

585 Just !x -> return x

586+ -}

590{-# INLINE forceHead #-}

587{-# INLINE forceHead #-}

591

588

592checkCR :: ByteString -> Int -> Int

589checkCR :: ByteString -> Int -> Int

warp/warp.cabal+4−4

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

1Name: warp

2−Version: 0.4.6.3

2+Version: 0.5.0

3Synopsis: A fast, light-weight web server for WAI applications.

4License: BSD3

5License-file: LICENSE

@@ -18,10 +18,10 @@ flag network-bytestring

18Library

19 Build-Depends: base >= 3 && < 5

20 , bytestring >= 0.9.1.4 && < 0.10

21− , wai >= 0.4 && < 0.5

21+ , wai >= 0.5 && < 0.6

22− , blaze-builder-enumerator >= 0.2 && < 0.3

23 , transformers >= 0.2.2 && < 0.3

22 , transformers >= 0.2.2 && < 0.3

24− , enumerator >= 0.4.8 && < 0.5

23+ , conduit >= 0.0 && < 0.1

24+ , lifted-base >= 0.1 && < 0.2

25 , blaze-builder >= 0.2.1.4 && < 0.4

26 , simple-sendfile >= 0.1 && < 0.3

27 , http-types >= 0.6 && < 0.7