67bb38e · typeable/wai

git.iko.soy/typeable/wai

conduit 0.2

commit67bb38e0de728bbba57362cf04b20d333a68fb38 authorMichael Snoyman <michael@snoyman.com> dateFri 27 Jan 2012, 16:42 (15 years ago) parentaa48b54

16 files changed+91−73

compare with master

unifiedsplit

conduit+1−1 wai-eventsource/src/Network/Wai/EventSource.hs+3−3 wai-eventsource/wai-eventsource.cabal+1−1 wai-extra/Network/Wai/Handler/CGI.hs+7−4 wai-extra/Network/Wai/Parse.hs+5−5 wai-extra/wai-extra.cabal+4−4 wai-frontend-monadcgi/wai-frontend-monadcgi.cabal+1−1 wai-handler-launch/Network/Wai/Handler/Launch.hs+7−7 wai-handler-launch/wai-handler-launch.cabal+10−10 wai-test/wai-test.cabal+2−2 wai-websockets/Network/Wai/Handler/WebSockets.hs+1−1 wai-websockets/wai-websockets.cabal+1−1 wai/wai.cabal+1−1 warp-tls/warp-tls.cabal+1−1 warp/Network/Wai/Handler/Warp.hs+44−29 warp/warp.cabal+2−2

conduit+1−1

Submodule changed.

wai-eventsource/src/Network/Wai/EventSource.hs+3−3

@@ -30,6 +30,6 @@ resE chan =

3030 pull Nothing = do

3131 x <- liftIO $ readChan chan

3232 return $ case eventToBuilder x of

33− Nothing -> (Nothing, C.Closed)

34− Just y -> (Just C.Flush, C.Open $ C.Chunk y)

35− pull (Just x) = return (Nothing, C.Open x)

33+ Nothing -> C.StateClosed

34+ Just y -> C.StateOpen (Just C.Flush) (C.Chunk y)

35+ pull (Just x) = return $ C.StateOpen Nothing x

wai-eventsource/wai-eventsource.cabal+1−1

@@ -17,7 +17,7 @@ Library

1717 base >= 4.3 && < 5

1818 , bytestring >= 0.9.1.4 && < 0.10

1919 , blaze-builder >= 0.3 && < 0.4

20− , conduit

20+ , conduit >= 0.2

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

2222 , wai >= 1.1

2323 , warp >= 1.1

wai-extra/Network/Wai/Handler/CGI.hs+7−4

@@ -144,8 +144,9 @@ runGeneric vars inputH outputH xsendfile app = do

144144 bsSink = C.Sink $ return $ C.SinkData push (return ())

145145 push (C.Chunk bs) = do

146146 liftIO $ outputH bs

147− return C.Processing

148− push C.Flush = return C.Processing

147+ return $ C.Processing push (return ())

148+ -- FIXME actually flush?

149+ push C.Flush = return $ C.Processing push (return ())

149150 builderSink = builderToByteStringFlush C.=$ bsSink

150151 fixHeaders h =

151152 case lookup "content-type" h of

@@ -174,8 +175,10 @@ requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> C.Source IO B.Byte

174175requestBodyFunc get count0 =

175176 C.sourceState count0 pull

176177 where

177− pull 0 = return (0, C.Closed)

178+ pull 0 = return C.StateClosed

178179 pull count = do

179180 mbs <- liftIO $ get $ min count defaultChunkSize

180181 let count' = count - maybe 0 B.length mbs

181− return (count', maybe C.Closed C.Open mbs)

182+ return $ case mbs of

183+ Nothing -> C.StateClosed

184+ Just bs -> C.StateOpen count' bs

wai-extra/Network/Wai/Parse.hs+5−5

@@ -197,10 +197,10 @@ takeLine =

197197 push front bs = do

198198 let (x, y) = S.break (== 10) $ front bs -- LF

199199 in if S.null y

200− then return (S.append x, C.Processing)

200+ then return $ C.StateProcessing $ S.append x

201201 else do

202202 let lo = if S.length y > 1 then Just (S.drop 1 y) else Nothing

203− return (error "takeLine", C.Done lo $ Just $ killCR x)

203+ return $ C.StateDone lo $ Just $ killCR x

204204

205205takeLines :: C.Sink S.ByteString IO [S.ByteString]

206206takeLines = do

@@ -306,7 +306,7 @@ sinkTillBound bound iter seed0 = C.sinkState

306306 FoundBound before after -> do

307307 let before' = killCRLF before

308308 seed' <- liftIO $ iter seed before'

309− return (undefined, C.Done (Just after) (seed', True))

309+ return $ C.StateDone (Just after) (seed', True)

310310 NoBound -> do

311311 -- don't emit newlines, in case it's part of a bound

312312 let (toEmit, front') =

@@ -315,8 +315,8 @@ sinkTillBound bound iter seed0 = C.sinkState

315315 in (x, S.append y)

316316 else (bs, id)

317317 seed' <- liftIO $ iter seed toEmit

318− return ((front', seed'), C.Processing)

319− PartialBound -> return ((S.append bs, seed), C.Processing)

318+ return $ C.StateProcessing (front', seed')

319+ PartialBound -> return $ C.StateProcessing (S.append bs, seed)

320320

321321parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]

322322parseAttrs = map go . S.split 59 -- semicolon

wai-extra/wai-extra.cabal+4−4

@@ -33,10 +33,10 @@ Library

3333 , text >= 0.7 && < 0.12

3434 , case-insensitive >= 0.2

3535 , data-default >= 0.3 && < 0.4

36− , fast-logger >= 0.0.1

37− , conduit

38− , zlib-conduit >= 0.0.2

39− , blaze-builder-conduit >= 0.0.1

36+ , fast-logger >= 0.0.1

37+ , conduit >= 0.2

38+ , zlib-conduit >= 0.2

39+ , blaze-builder-conduit >= 0.2

4040

4141 Exposed-modules: Network.Wai.Handler.CGI

4242 Network.Wai.Middleware.AcceptOverride

wai-frontend-monadcgi/wai-frontend-monadcgi.cabal+1−1

@@ -16,7 +16,7 @@ library

1616 , bytestring

1717 , containers >= 0.2

1818 , cgi

19− , conduit >= 0.0.1

19+ , conduit >= 0.2

2020 , http-types

2121 , transformers

2222 , case-insensitive

wai-handler-launch/Network/Wai/Handler/Launch.hs+7−7

@@ -65,24 +65,24 @@ insideHead =

6565 C.conduitState (Just (S.empty, whole)) push' close

6666 where

6767 whole = "<head>"

68− push' state (C.Chunk x) = (fmap . fmap . fmap) C.Chunk (push state x)

69− push' state C.Flush = return (state, C.Producing [C.Flush])

68+ push' state (C.Chunk x) = (fmap . fmap) C.Chunk (push state x)

69+ push' state C.Flush = return $ C.StateProducing state [C.Flush]

7070 push (Just (held, atFront)) x

7171 | atFront `S.isPrefixOf` x = do

7272 let y = S.drop (S.length atFront) x

73− return (Nothing, C.Producing [held, atFront, toInsert, y])

73+ return $ C.StateProducing Nothing [held, atFront, toInsert, y]

7474 | whole `S.isInfixOf` x = do

7575 let (before, rest) = S.breakSubstring whole x

7676 let after = S.drop (S.length whole) rest

77− return (Nothing, C.Producing [held, before, whole, toInsert, after])

77+ return $ C.StateProducing Nothing [held, before, whole, toInsert, after]

7878 | x `S.isPrefixOf` atFront = do

7979 let held' = held `S.append` x

8080 atFront' = S.drop (S.length x) atFront

81− return (Just (held', atFront'), C.Producing [])

81+ return $ C.StateProducing (Just (held', atFront')) []

8282 | otherwise = do

8383 let (held', atFront', x') = getOverlap whole x

84− return (Just (held', atFront'), C.Producing [held, x'])

85− push Nothing x = return (Nothing, C.Producing [x])

84+ return $ C.StateProducing (Just (held', atFront')) [held, x']

85+ push Nothing x = return $ C.StateProducing Nothing [x]

8686

8787 close (Just (held, _)) = return [C.Chunk held, C.Chunk toInsert]

8888 close Nothing = return []

wai-handler-launch/wai-handler-launch.cabal+10−10

@@ -12,16 +12,16 @@ Cabal-version: >=1.2

1212

1313Library

1414 Exposed-modules: Network.Wai.Handler.Launch

15− build-depends: base >= 4 && < 5

16− , wai >= 1.1 && < 1.2

17− , warp >= 1.1 && < 1.2

18− , http-types >= 0.6 && < 0.7

19− , transformers >= 0.2.2 && < 0.3

20− , bytestring >= 0.9.1.4 && < 0.10

21− , blaze-builder >= 0.2.1.4 && < 0.4

22− , conduit

23− , blaze-builder-conduit

24− , zlib-conduit

15+ build-depends: base >= 4 && < 5

16+ , wai >= 1.1 && < 1.2

17+ , warp >= 1.1 && < 1.2

18+ , http-types >= 0.6 && < 0.7

19+ , transformers >= 0.2.2 && < 0.3

20+ , bytestring >= 0.9.1.4 && < 0.10

21+ , blaze-builder >= 0.2.1.4 && < 0.4

22+ , conduit >= 0.2

23+ , blaze-builder-conduit >= 0.2

24+ , zlib-conduit >= 0.2

2525

2626 if os(windows)

2727 c-sources: windows.c

wai-test/wai-test.cabal+2−2

@@ -19,8 +19,8 @@ library

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

2020 , transformers >= 0.2.2 && < 0.3

2121 , containers >= 0.2 && < 0.5

22− , conduit

23− , blaze-builder-conduit >= 0.0 && < 0.1

22+ , conduit >= 0.2

23+ , blaze-builder-conduit >= 0.2 && < 0.3

2424 , cookie >= 0.2 && < 0.4

2525 , HUnit >= 1.2 && < 1.3

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

wai-websockets/Network/Wai/Handler/WebSockets.hs+1−1

@@ -53,4 +53,4 @@ runWebSockets opts req app source conn = do

5353

5454 push iter bs = do

5555 step <- liftIO $ E.runIteratee $ E.enumList 1 [bs] E.$$ iter

56− return (E.returnI step, C.Processing)

56+ return $ C.StateProcessing $ E.returnI step

wai-websockets/wai-websockets.cabal+1−1

@@ -19,7 +19,7 @@ flag example

1919Library

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

2121 , bytestring >= 0.9.1.4 && < 0.10

22− , conduit

22+ , conduit >= 0.2

2323 , wai >= 1.1 && < 1.2

2424 , warp >= 1.1 && < 1.2

2525 , enumerator >= 0.4.8 && < 0.5

wai/wai.cabal+1−1

@@ -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− , conduit >= 0.1.2

23+ , conduit >= 0.2

2424 , network >= 2.2.1.5 && < 2.4

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

2626 , text >= 0.7 && < 0.12

warp-tls/warp-tls.cabal+1−1

@@ -18,7 +18,7 @@ Library

1818 , wai >= 1.1 && < 1.2

1919 , warp >= 1.1 && < 1.2

2020 , transformers >= 0.2 && < 0.3

21− , conduit

21+ , conduit >= 0.2

2222 , certificate >= 1.0.1 && < 1.1

2323 , cryptocipher >= 0.3 && < 0.4

2424 , tls-extra >= 0.4 && < 0.5

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

@@ -92,7 +92,6 @@ import Data.Typeable (Typeable)

9292

9393import Control.Monad.Trans.Resource (ResourceT, runResourceT)

9494import qualified Data.Conduit as C

95−import qualified Data.Conduit.Binary as CB

9695import qualified Data.Conduit.List as CL

9796import Data.Conduit.Blaze (builderToByteString)

9897import Control.Exception.Lifted (throwIO)

@@ -116,7 +115,7 @@ import qualified Network.HTTP.Types as H

116115import qualified Data.CaseInsensitive as CI

117116import System.IO (hPutStrLn, stderr)

118117import ReadInt (readInt64)

119−

118+import qualified Data.IORef as I

120119

121120#if WINDOWS

122121import Control.Concurrent (threadDelay)

@@ -322,17 +321,32 @@ parseRequest' port (firstLine:otherLines) remoteHost' src = do

322321 | otherwise = ("", rpath')

323322 let heads = map parseHeaderNoAttr otherLines

324323 let host = fromMaybe host' $ lookup "host" heads

325− let len =

324+ let len0 =

326325 case lookup "content-length" heads of

327326 Nothing -> 0

328327 Just bs -> readInt bs

329328 let serverName' = takeUntil 58 host -- ':'

330329 -- FIXME isolate takes an Integer instead of Int or Int64. If this is a

331330 -- performance penalty, we may need our own version.

332− rbody <- C.prepareSource $

333− if len == 0

334− then mempty

335− else src C.$= CB.isolate len

331+ rbody <-

332+ if len0 == 0

333+ then return mempty

334+ else do

335+ -- We can't use the standard isolate, as its counter is not

336+ -- kept in a mutable variable.

337+ lenRef <- liftIO $ I.newIORef len0

338+ let isolate = C.Conduit $ return $ C.PreparedConduit push close

339+ push bs = do

340+ len <- liftIO $ I.readIORef lenRef

341+ let (a, b) = S.splitAt len bs

342+ len' = len - S.length a

343+ liftIO $ I.writeIORef lenRef len'

344+ return $ if len' == 0

345+ then C.Finished (if S.null b then Nothing else Just b) (if S.null a then [] else [a])

346+ else C.Producing push close [a]

347+ close = return []

348+ psrc <- C.prepareSource $ src C.$= isolate

349+ return $ C.Source $ return psrc

336350 return Request

337351 { requestMethod = method

338352 , httpVersion = httpversion

@@ -345,7 +359,7 @@ parseRequest' port (firstLine:otherLines) remoteHost' src = do

345359 , requestHeaders = heads

346360 , isSecure = False

347361 , remoteHost = remoteHost'

348− , requestBody = C.Source $ return rbody

362+ , requestBody = rbody

349363 , vault = mempty

350364 }

351365

@@ -515,7 +529,7 @@ sendResponse th req conn r = sendResponse' r

515529 , C.conduitClose = close

516530 }

517531

518− push x = return $ C.Producing [chunkedTransferEncoding x]

532+ push x = return $ C.Producing push close [chunkedTransferEncoding x]

519533 close = return [chunkedTransferTerminator]

520534

521535parseHeaderNoAttr :: ByteString -> H.Header

@@ -529,23 +543,24 @@ parseHeaderNoAttr s =

529543 in (CI.mk k, rest')

530544

531545connSource :: Connection -> T.Handle -> C.PreparedSource IO ByteString

532−connSource Connection { connRecv = recv } th = C.PreparedSource

533− { C.sourcePull = do

534− bs <- liftIO recv

535− if S.null bs

536− then return C.Closed

537− else do

538− when (S.length bs >= 2048) $ liftIO $ T.tickle th

539− return (C.Open bs)

540− , C.sourceClose = return ()

541− }

546+connSource Connection { connRecv = recv } th =

547+ src

548+ where

549+ src = C.PreparedSource

550+ { C.sourcePull = do

551+ bs <- liftIO recv

552+ if S.null bs

553+ then return C.Closed

554+ else do

555+ when (S.length bs >= 2048) $ liftIO $ T.tickle th

556+ return (C.Open src bs)

557+ , C.sourceClose = return ()

558+ }

542559

543560-- | Use 'connSendAll' to send this data while respecting timeout rules.

544561connSink :: Connection -> T.Handle -> C.Sink B.ByteString IO ()

545−connSink Connection { connSendAll = send } th = C.Sink $ return C.SinkData

546− { C.sinkPush = push

547− , C.sinkClose = close

548− }

562+connSink Connection { connSendAll = send } th =

563+ C.Sink $ return $ C.SinkData push close

549564 where

550565 close = liftIO (T.resume th)

551566 push x = do

@@ -553,7 +568,7 @@ connSink Connection { connSendAll = send } th = C.Sink $ return C.SinkData

553568 T.resume th

554569 send x

555570 T.pause th

556− return C.Processing

571+ return (C.Processing push close)

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

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

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

@@ -616,7 +631,7 @@ takeHeaders =

616631

617632takeHeadersPush :: THStatus

618633 -> ByteString

619− -> ResourceT IO (THStatus, C.SinkResult ByteString [ByteString])

634+ -> ResourceT IO (C.SinkStateResult THStatus ByteString [ByteString])

620635takeHeadersPush (THStatus len _ _ ) _

621636 | len > maxTotalHeaderLength = throwIO OverLargeHeader

622637takeHeadersPush (THStatus len lines prepend) bs =

@@ -624,7 +639,7 @@ takeHeadersPush (THStatus len lines prepend) bs =

624639 -- no newline. prepend entire bs to next line

625640 Nothing -> do

626641 let len' = len + bsLen

627− return (THStatus len' lines (prepend . S.append bs), C.Processing)

642+ return $ C.StateProcessing $ THStatus len' lines (prepend . S.append bs)

628643 Just nl -> do

629644 let end = nl

630645 start = nl + 1

@@ -638,8 +653,8 @@ takeHeadersPush (THStatus len lines prepend) bs =

638653 if start < bsLen

639654 then do

640655 let rest = SU.unsafeDrop start bs

641− return (undefined, C.Done (Just rest) lines')

642− else return (undefined, C.Done Nothing lines')

656+ return $ C.StateDone (Just rest) lines'

657+ else return $ C.StateDone Nothing lines'

643658 -- more headers

644659 else do

645660 let len' = len + start

@@ -648,7 +663,7 @@ takeHeadersPush (THStatus len lines prepend) bs =

648663 then do

649664 let more = SU.unsafeDrop start bs

650665 takeHeadersPush (THStatus len' lines' id) more

651− else return (THStatus len' lines' id, C.Processing)

666+ else return $ C.StateProcessing $ THStatus len' lines' id

652667 where

653668 bsLen = S.length bs

654669 mnl = S.elemIndex 10 bs

warp/warp.cabal+2−2

@@ -21,8 +21,8 @@ Library

2121 , bytestring >= 0.9.1.4 && < 0.10

2222 , wai >= 1.1 && < 1.2

2323 , transformers >= 0.2.2 && < 0.3

24− , conduit

25− , blaze-builder-conduit >= 0.0.1 && < 0.1

24+ , conduit >= 0.2

25+ , blaze-builder-conduit >= 0.2 && < 0.3

2626 , lifted-base >= 0.1 && < 0.2

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

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