263f483 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Warp now works (somewhat)

263f483Michael Snoyman15 years ago

conduit/Data/Conduit.hs+1−3

compare with master

unifiedsplit

@@ -83,9 +83,7 @@ appHelper istate f a stream = do

83 Just res -> do

84 let state' = Just $ Left res

85 liftBase $ I.writeIORef istate state'

86− if null leftover

87− then return $ SinkResult [] Nothing

88− else go state' $ Chunks leftover

86+ go state' $ Chunks leftover

90instance MonadBaseControl IO m => Monad (Sink input m) where

88instance MonadBaseControl IO m => Monad (Sink input m) where

91 return = pure

89 return = pure

conduit/Data/Conduit/List.hs+10−1

@@ -5,10 +5,11 @@ module Data.Conduit.List

5 , take

6 , map

7 , concatMap

8+ , head

8 ) where

9 ) where

10import qualified Prelude

11import qualified Prelude

11−import Prelude hiding (take, map, concatMap)

12+import Prelude hiding (take, map, concatMap, head)

12import Data.Conduit

13import Data.Conduit

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

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

14import Control.Monad.Base (liftBase)

15import Control.Monad.Base (liftBase)

@@ -55,6 +56,14 @@ take count0 = Sink $ do

55 in ((count', rest'), (count', rest', b))

56 in ((count', rest'), (count', rest', b))

56 return $ SinkResult b $ if count == 0 then Just rest' else Nothing

57 return $ SinkResult b $ if count == 0 then Just rest' else Nothing

59+head :: MonadBaseControl IO m => Sink a m (Maybe a)

60+head =

61+ Sink $ return $ return . go

62+ where

63+ go EOF = SinkResult [] $ Just Nothing

64+ go (Chunks []) = SinkResult [] Nothing

65+ go (Chunks (a:as)) = SinkResult as (Just (Just a))

66+

58map :: Monad m => (a -> b) -> Conduit a m b

67map :: Monad m => (a -> b) -> Conduit a m b

59map f a = return $ ConduitResult [] $ fmap f a

68map f a = return $ ConduitResult [] $ fmap f a

warp/Network/Wai/Handler/Warp.hs+34−30

@@ -209,7 +209,7 @@ serveConnection settings th onException port app conn remoteHost' = do

209 fromClient = sourceSocket th bytesPerRead conn

210 serveConnection' :: ResourceT IO ()

211 serveConnection' = do

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

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

213 case settingsIntercept settings env of

214 Nothing -> do

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

@@ -218,14 +218,16 @@ serveConnection settings th onException port app conn remoteHost' = do

218 liftIO $ T.resume th

219 keepAlive <- liftIO $ sendResponse th env conn res

220 if keepAlive then serveConnection' else return ()

221− Just intercept -> undefined {-do

221+ Just intercept -> error "intercept" {-do

222 liftIO $ T.pause th

223 intercept conn-}

224

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

225+parseRequest :: Port -> SockAddr

226+ -> C.Source IO S.ByteString

227+ -> ResourceT IO (Integer, Request)

226−parseRequest port remoteHost' = do

228+parseRequest port remoteHost' src = do

227− headers' <- takeHeaders

229+ headers' <- takeHeaders src

228− parseRequest' port headers' remoteHost'

230+ parseRequest' port headers' remoteHost' src

229

231

230-- FIXME come up with good values here

232-- FIXME come up with good values here

231bytesPerRead, maxTotalHeaderLength :: Int

233bytesPerRead, maxTotalHeaderLength :: Int

@@ -246,9 +248,10 @@ instance Exception InvalidRequest

246parseRequest' :: Port

248parseRequest' :: Port

247 -> [ByteString]

249 -> [ByteString]

248 -> SockAddr

250 -> SockAddr

251+ -> C.Source IO S.ByteString

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

252+ -> ResourceT IO (Integer, Request)

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

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

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

254+parseRequest' port (firstLine:otherLines) remoteHost' src = do

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

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

253 let (host',rpath) =

256 let (host',rpath) =

254 if S.null rpath'

257 if S.null rpath'

@@ -277,6 +280,7 @@ parseRequest' port (firstLine:otherLines) remoteHost' = do

277 , requestHeaders = heads

280 , requestHeaders = heads

278 , isSecure = False

281 , isSecure = False

279 , remoteHost = remoteHost'

282 , remoteHost = remoteHost'

283+ , requestBody = src -- FIXME isolate

280 })

284 })

281

285

282

286

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

288{-# INLINE takeUntil #-}

292{-# INLINE takeUntil #-}

289

293

290parseFirst :: ByteString

294parseFirst :: ByteString

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

295+ -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)

292parseFirst s =

296parseFirst s =

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

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

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

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

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

420 `mappend` chunkedTransferTerminator

424 `mappend` chunkedTransferTerminator

421 else (headers' False) `mappend` b

425 else (headers' False) `mappend` b

422

426

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

427+ sendResponse' (ResponseEnumerator res) = error "sendResponse'" {-res enumResponse

424 where

428 where

425 enumResponse s hs = response True

429 enumResponse s hs = response True

426 where

430 where

@@ -522,10 +526,10 @@ defaultSettings = Settings

522 go' (Just ThreadKilled) = False

526 go' (Just ThreadKilled) = False

523 go' _ = True

527 go' _ = True

524

528

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

529+takeHeaders :: C.Source IO ByteString -> ResourceT IO [ByteString]

526−takeHeaders = do

530+takeHeaders src = do

527− !x <- forceHead ConnectionClosedByPeer

531+ !x <- forceHead ConnectionClosedByPeer src

528− takeHeaders' 0 id id x

532+ takeHeaders' 0 id id x src

529

533

530{-# INLINE takeHeaders #-}

534{-# INLINE takeHeaders #-}

531

535

@@ -533,17 +537,18 @@ takeHeaders' :: Int

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

537 -> ([ByteString] -> [ByteString])

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

538 -> ([ByteString] -> [ByteString])

535 -> ByteString

539 -> ByteString

540+ -> C.Source IO ByteString

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

541+ -> ResourceT IO [ByteString]

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

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

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

543+takeHeaders' !len !lines !prepend !bs src = do

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

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

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

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

541 case mnl of

546 case mnl of

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

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

543 !Nothing -> {-# SCC "takeHeaders'.noNewline" #-} do

548 !Nothing -> {-# SCC "takeHeaders'.noNewline" #-} do

544 let !len' = len + bsLen

549 let !len' = len + bsLen

545− !more <- forceHead IncompleteHeaders

550+ !more <- forceHead IncompleteHeaders src

546− takeHeaders' len' lines (prepend . (:) bs) more

551+ takeHeaders' len' lines (prepend . (:) bs) more src

547 Just !nl -> {-# SCC "takeHeaders'.newline" #-} do

552 Just !nl -> {-# SCC "takeHeaders'.newline" #-} do

548 let !end = nl

553 let !end = nl

549 !start = nl + 1

554 !start = nl + 1

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

561 if start < bsLen

566 if start < bsLen

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

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

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

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

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

569+ error "yield" -- E.yield lines' $! E.Chunks [rest]

565 else return lines'

570 else return lines'

566

571

567 -- more headers

572 -- more headers

@@ -571,19 +576,18 @@ takeHeaders' !len !lines !prepend !bs = do

571 !more <- {-# SCC "takeHeaders'.more" #-}

576 !more <- {-# SCC "takeHeaders'.more" #-}

572 if start < bsLen

577 if start < bsLen

573 then return $! SU.unsafeDrop start bs

578 then return $! SU.unsafeDrop start bs

574− else forceHead IncompleteHeaders

579+ else forceHead IncompleteHeaders src

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

580+ {-# SCC "takeHeaders'.takeMore" #-} takeHeaders' len' lines' id more src

576{-# INLINE takeHeaders' #-}

581{-# INLINE takeHeaders' #-}

577

582

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

583+forceHead :: InvalidRequest

584+ -> C.Source IO ByteString

585+ -> ResourceT IO ByteString

579−forceHead err = do

586+forceHead err src = do

580− undefined

581− {-

582− !mx <- EL.head

587+ !mx <- src C.$$ CL.head

583 case mx of

588 case mx of

584− !Nothing -> E.throwError err

585 Just !x -> return x

589 Just !x -> return x

586− -}

590+ Nothing -> throwIO err

587{-# INLINE forceHead #-}

591{-# INLINE forceHead #-}

588

592

589checkCR :: ByteString -> Int -> Int

593checkCR :: ByteString -> Int -> Int

warp/pong.hs−18

@@ -4,7 +4,6 @@ import Network.Wai.Handler.Warp

4import Network.HTTP.Types (status200)

5import Blaze.ByteString.Builder (copyByteString)

6import Data.Monoid

7−import Data.Enumerator (run_, enumList, ($$))

9main = run 3000 app

8main = run 3000 app

@@ -12,8 +11,6 @@ app req = return $

12 case rawPathInfo req of

11 case rawPathInfo req of

13 "/builder/withlen" -> builderWithLen

12 "/builder/withlen" -> builderWithLen

14 "/builder/nolen" -> builderNoLen

13 "/builder/nolen" -> builderNoLen

15− "/enum/withlen" -> enumWithLen

16− "/enum/nolen" -> enumNoLen

17 "/file/withlen" -> fileWithLen

14 "/file/withlen" -> fileWithLen

18 "/file/nolen" -> fileNoLen

15 "/file/nolen" -> fileNoLen

19 x -> index x

16 x -> index x

@@ -46,24 +43,9 @@ fileNoLen = ResponseFile

46 "pong.txt"

43 "pong.txt"

47 Nothing

44 Nothing

49−enumWithLen = ResponseEnumerator $ \f ->

50− run_ $ (enumList 1 $ map copyByteString ["P", "O", "NG"]) $$ f

51− status200

52− [ ("Content-Type", "text/plain")

53− , ("Content-Length", "4")

54− ]

55−

56−enumNoLen = ResponseEnumerator $ \f ->

57− run_ $ (enumList 1 $ map copyByteString ["P", "O", "NG"]) $$ f

58− status200

59− [ ("Content-Type", "text/plain")

60− ]

61−

62index p = ResponseBuilder status200 [("Content-Type", "text/html")] $ mconcat $ map copyByteString

46index p = ResponseBuilder status200 [("Content-Type", "text/html")] $ mconcat $ map copyByteString

63 [ "<a href='/builder/withlen'>builder withlen</a>\n"

47 [ "<a href='/builder/withlen'>builder withlen</a>\n"

64 , "<a href='/builder/nolen'>builder nolen</a>\n"

48 , "<a href='/builder/nolen'>builder nolen</a>\n"

65− , "<a href='/enum/withlen'>enum withlen</a>\n"

66− , "<a href='/enum/nolen'>enum nolen</a>\n"

67 , "<a href='/file/withlen'>file withlen</a>\n"

49 , "<a href='/file/withlen'>file withlen</a>\n"

68 , "<a href='/file/nolen'>file nolen</a>\n"

50 , "<a href='/file/nolen'>file nolen</a>\n"

69 , p

51 , p