360442a · typeable/wai

git.iko.soy/typeable/wai

Began moving wai/warp to conduit

commit360442ac74f7e79bb0e320110056b3f44e15107c authorMichael <michael@snoyman.com> dateThu 8 Dec 2011, 20:21 (15 years ago) parent4cc6156

5 files changed+80−67

compare with master

unifiedsplit

conduit/Data/Conduit.hs+17−4 wai/Network/Wai.hs+12−9 wai/wai.cabal+2−2 warp/Network/Wai/Handler/Warp.hs+45−48 warp/warp.cabal+4−4

conduit/Data/Conduit.hs+17−4

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

11{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE UndecidableInstances #-}

25{-# LANGUAGE DeriveDataTypeable #-}

36module Data.Conduit

47 ( -- * Helper types

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

1922

2023import Control.Monad.Trans.Resource

2124import 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))

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

2428import qualified Data.IORef as I

2529import Data.Typeable (Typeable)

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

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

5458 pure x =

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

56− where

57− toList EOF = []

58− toList (Chunks a) = a

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

6061 istate <- liftBase $ I.newIORef Nothing

6162 f <- mf

6263 a <- ma

6364 return $ appHelper istate f a

6465

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

67+toList EOF = []

68+toList (Chunks a) = a

69+

6570appHelper :: MonadBaseControl IO m

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

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

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

8691 return = pure

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

8893

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+

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

90103sinkJoin (Sink mmsink) = Sink $ do

91104 istate <- liftBase $ I.newIORef Nothing

wai/Network/Wai.hs+12−9

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

5151import qualified Data.ByteString as B

5252import qualified Data.ByteString.Lazy as L

5353import Data.Typeable (Typeable)

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

55−import qualified Data.Enumerator as E

56−import qualified Data.Enumerator.List as EL

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

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

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

55+import qualified Data.Conduit as C

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

5957import Network.Socket (SockAddr)

6058import qualified Network.HTTP.Types as H

6159import Data.Text (Text)

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

9492 , pathInfo :: [Text]

9593 -- | Parsed query string information

9694 , queryString :: H.Query

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

9796 }

98− deriving (Show, Typeable)

97+ deriving (Typeable)

9998

10099data Response

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

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

133132-- optimal size by sending a flush command.

134133

135134type 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

137137

138138responseEnumerator :: Response -> ResponseEnumerator a

139+responseEnumerator = undefined

140+{-

139141responseEnumerator (ResponseEnumerator e) f = e f

140142responseEnumerator (ResponseFile s h fp mpart) f =

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

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

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

145147 f s h

146148

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

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

148150enumFilePart (FilePart offset count) fp =

149151 enumFileRange fp (Just offset) (Just count)

152+-}

150153

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

152155responseLBS s h = ResponseBuilder s h . fromLazyByteString

153156

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

157+type Application = Request -> ResourceT IO Response

155158

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

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

wai/wai.cabal+2−2

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

11Name: wai

2−Version: 0.4.3

2+Version: 0.5.0

33Synopsis: Web Application Interface.

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

55License: BSD3

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

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

2121 , bytestring >= 0.9.1.4 && < 0.10

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

23− , enumerator >= 0.4.8 && < 0.5

23+ , conduit >= 0.0 && < 0.1

2424 , network >= 2.2.1.5 && < 2.4

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

2626 , text >= 0.7 && < 0.12

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

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

4646 , sendResponse

4747 , registerKillThread

4848 , bindPort

49− , enumSocket

5049 , pause

5150 , resume

5251 , T.cancel

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

8685

8786import Data.Typeable (Typeable)

8887

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

90−import qualified Data.Enumerator as E

91−import qualified Data.Enumerator.List as EL

92−import qualified Data.Enumerator.Binary as EB

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

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

89+import qualified Data.Conduit as C

90+import qualified Data.Conduit.List as CL

91+import Control.Exception.Lifted (throwIO)

9492import Blaze.ByteString.Builder.HTTP

9593 (chunkedTransferEncoding, chunkedTransferTerminator)

9694import Blaze.ByteString.Builder

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

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

205203 catch

206204 (finally

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

205+ (runResourceT serveConnection')

208206 (sClose conn))

209207 onException

210208 where

211− fromClient = enumSocket th bytesPerRead conn

209+ fromClient = sourceSocket th bytesPerRead conn

210+ serveConnection' :: ResourceT IO ()

212211 serveConnection' = do

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

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

214213 case settingsIntercept settings env of

215214 Nothing -> do

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

217216 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

219218 liftIO $ T.resume th

220219 keepAlive <- liftIO $ sendResponse th env conn res

221220 if keepAlive then serveConnection' else return ()

222− Just intercept -> do

221+ Just intercept -> undefined {-do

223222 liftIO $ T.pause th

224− intercept conn

223+ intercept conn-}

225224

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

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

227226parseRequest port remoteHost' = do

228227 headers' <- takeHeaders

229228 parseRequest' port headers' remoteHost'

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

247246parseRequest' :: Port

248247 -> [ByteString]

249248 -> SockAddr

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

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

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

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

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

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

254253 let (host',rpath) =

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

289288{-# INLINE takeUntil #-}

290289

291290parseFirst :: ByteString

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

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

293292parseFirst s =

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

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

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

301300 "1.1" -> H.http11

302301 _ -> H.http10

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

304− else E.throwError NonHttp

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

303+ else throwIO NonHttp

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

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

307306

308307httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder

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

421420 `mappend` chunkedTransferTerminator

422421 else (headers' False) `mappend` b

423422

424− sendResponse' (ResponseEnumerator res) = res enumResponse

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

425424 where

426425 enumResponse s hs = response True

427426 where

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

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

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

448447 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 -}

450449

451450parseHeaderNoAttr :: ByteString -> H.Header

452451parseHeaderNoAttr s =

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

458457 else rest

459458 in (CI.mk k, rest')

460459

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

462−enumSocket th len socket =

463− inner

464− where

465− inner (E.Continue k) = do

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

467− liftIO $ T.tickle th

468− if S.null bs

469− then E.continue k

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

471− inner step = E.returnI step

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

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

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

463+ liftIO $ T.tickle th

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

465+

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

473467--separate package.

474468

475−iterSocket :: T.Handle

469+sinkSocket :: T.Handle

476470 -> Socket

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

478−iterSocket th sock =

479− E.continue step

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

472+sinkSocket th sock =

473+ C.Sink $ return go

480474 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

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

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

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

484485 -- 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

492486

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

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

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

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

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

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

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

506500 }

507501

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

528522 go' (Just ThreadKilled) = False

529523 go' _ = True

530524

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

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

532526takeHeaders = do

533527 !x <- forceHead ConnectionClosedByPeer

534528 takeHeaders' 0 id id x

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

539533 -> ([ByteString] -> [ByteString])

540534 -> ([ByteString] -> [ByteString])

541535 -> ByteString

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

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

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

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

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

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

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

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

567561 if start < bsLen

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

569563 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]

571565 else return lines'

572566

573567 -- more headers

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

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

582576{-# INLINE takeHeaders' #-}

583577

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

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

585579forceHead err = do

580+ undefined

581+ {-

586582 !mx <- EL.head

587583 case mx of

588584 !Nothing -> E.throwError err

589585 Just !x -> return x

586+ -}

590587{-# INLINE forceHead #-}

591588

592589checkCR :: ByteString -> Int -> Int

warp/warp.cabal+4−4

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

11Name: warp

2−Version: 0.4.6.3

2+Version: 0.5.0

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

44License: BSD3

55License-file: LICENSE

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

1818Library

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

2020 , bytestring >= 0.9.1.4 && < 0.10

21− , wai >= 0.4 && < 0.5

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

21+ , wai >= 0.5 && < 0.6

2322 , 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

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

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

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