792cef2 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

support chunked request #17

792cef2yihuang14 years ago

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

compare with master

unifiedsplit

@@ -107,6 +107,7 @@ import System.IO (hPrint, stderr)

107import ReadInt (readInt64)

108import qualified Data.IORef as I

109import Data.Conduit.Network (bindPort, HostPreference (HostIPv4))

110+import Network.HTTP.Conduit.Chunk (chunkedConduit)

110

111

111#if WINDOWS

112#if WINDOWS

112import Control.Concurrent (threadDelay)

113import Control.Concurrent (threadDelay)

@@ -269,6 +270,17 @@ ibsIsolate ibs@(IsolatedBSSource ref) =

269ibsDone :: IsolatedBSSource -> IO (C.Source (ResourceT IO) ByteString)

270ibsDone :: IsolatedBSSource -> IO (C.Source (ResourceT IO) ByteString)

270ibsDone (IsolatedBSSource ref) = fmap snd $ I.readIORef ref

271ibsDone (IsolatedBSSource ref) = fmap snd $ I.readIORef ref

271

272

273+refSource :: MonadIO m => I.IORef (C.Source m a) -> C.Source m a

274+refSource ref = C.PipeM pull (return ())

275+ where

276+ pull = do

277+ src <- liftIO $ I.readIORef ref

278+ (src', ma) <- src C.$$+ CL.head

279+ liftIO $ I.writeIORef ref src'

280+ case ma of

281+ Nothing -> return $ C.Done Nothing ()

282+ Just a -> return $ C.HaveOutput (refSource ref) (return ()) a

283+

272serveConnection :: Settings

284serveConnection :: Settings

273 -> T.Handle

285 -> T.Handle

274 -> (SomeException -> IO ())

286 -> (SomeException -> IO ())

@@ -286,7 +298,7 @@ serveConnection settings th onException port app conn remoteHost' =

286 serveConnection'' fromClient

298 serveConnection'' fromClient

287

299

288 serveConnection'' fromClient = do

300 serveConnection'' fromClient = do

289− (env, ibs) <- parseRequest conn port remoteHost' fromClient

301+ (env, getSource) <- parseRequest conn port remoteHost' fromClient

290 case settingsIntercept settings env of

302 case settingsIntercept settings env of

291 Nothing -> do

303 Nothing -> do

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

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

@@ -294,20 +306,20 @@ serveConnection settings th onException port app conn remoteHost' =

294 res <- app env

306 res <- app env

295

307

296 -- flush the rest of the request body

308 -- flush the rest of the request body

297− ibsIsolate ibs C.$$ CL.sinkNull

309+ requestBody env C.$$ CL.sinkNull

298− fromClient' <- liftIO $ ibsDone ibs

310+ fromClient' <- liftIO getSource

299

311

300 liftIO $ T.resume th

312 liftIO $ T.resume th

301 keepAlive <- sendResponse th env conn res

313 keepAlive <- sendResponse th env conn res

302 when keepAlive $ serveConnection'' fromClient'

314 when keepAlive $ serveConnection'' fromClient'

303 Just intercept -> do

315 Just intercept -> do

304 liftIO $ T.pause th

316 liftIO $ T.pause th

305− fromClient' <- liftIO $ ibsDone ibs

317+ fromClient' <- liftIO getSource

306 intercept fromClient' conn

318 intercept fromClient' conn

307

319

308parseRequest :: Connection -> Port -> SockAddr

320parseRequest :: Connection -> Port -> SockAddr

309 -> C.Source (ResourceT IO) S.ByteString

321 -> C.Source (ResourceT IO) S.ByteString

310− -> ResourceT IO (Request, IsolatedBSSource)

322+ -> ResourceT IO (Request, IO (C.Source (ResourceT IO) ByteString))

311parseRequest conn port remoteHost' src1 = do

323parseRequest conn port remoteHost' src1 = do

312 (src2, headers') <- src1 C.$$+ takeHeaders

324 (src2, headers') <- src1 C.$$+ takeHeaders

313 parseRequest' conn port headers' remoteHost' src2

325 parseRequest' conn port headers' remoteHost' src2

@@ -347,7 +359,7 @@ parseRequest' :: Connection

347 -> [ByteString]

359 -> [ByteString]

348 -> SockAddr

360 -> SockAddr

349 -> C.Source (ResourceT IO) S.ByteString -- FIXME was buffered

361 -> C.Source (ResourceT IO) S.ByteString -- FIXME was buffered

350− -> ResourceT IO (Request, IsolatedBSSource)

362+ -> ResourceT IO (Request, IO (C.Source (ResourceT IO) ByteString))

351parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines []

363parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines []

352parseRequest' conn port (firstLine:otherLines) remoteHost' src = do

364parseRequest' conn port (firstLine:otherLines) remoteHost' src = do

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

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

@@ -364,9 +376,17 @@ parseRequest' conn port (firstLine:otherLines) remoteHost' src = do

364 Nothing -> 0

376 Nothing -> 0

365 Just bs -> readInt bs

377 Just bs -> readInt bs

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

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

379+ let chunked = maybe False (=="chunked")

380+ $ lookup "transfer-encoding" heads

367− (rbody, ibs) <- liftIO $ do

381+ (rbody, getSource) <- liftIO $

382+ if chunked

383+ then do

384+ ref <- I.newIORef (src C.$= chunkedConduit False)

385+ return (refSource ref, I.readIORef ref)

386+ else do

368− ibs <- fmap IsolatedBSSource $ I.newIORef (len0, src)

387+ ibs <- fmap IsolatedBSSource $ I.newIORef (len0, src)

369− return (ibsIsolate ibs, ibs)

388+ return (ibsIsolate ibs, ibsDone ibs)

389+

370 return (Request

390 return (Request

371 { requestMethod = method

391 { requestMethod = method

372 , httpVersion = httpversion

392 , httpVersion = httpversion

@@ -381,7 +401,7 @@ parseRequest' conn port (firstLine:otherLines) remoteHost' src = do

381 , remoteHost = remoteHost'

401 , remoteHost = remoteHost'

382 , requestBody = rbody

402 , requestBody = rbody

383 , vault = mempty

403 , vault = mempty

384− }, ibs)

404+ }, getSource)

385

405

386

406

387takeUntil :: Word8 -> ByteString -> ByteString

407takeUntil :: Word8 -> ByteString -> ByteString

warp/print-post.hsnew file+18

@@ -0,0 +1,18 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.Wai.Handler.Warp

4+import Network.HTTP.Types (status200)

5+import Blaze.ByteString.Builder (fromByteString)

6+import qualified Data.Conduit as C

7+import qualified Data.Conduit.List as CL

8+import Control.Monad.IO.Class (liftIO)

10+{-

11+ - use `curl -H "Transfer-Encoding: chunked" estfile http://localhost:3000/` to send a chunked post request.

12+ -}

13+

14+main = run 3000 app

15+

16+app req = do

17+ (requestBody req C.$$ CL.consume) >>= liftIO . print

18+ return $ ResponseBuilder status200 [] (fromByteString "PONG")

warp/warp.cabal+1

@@ -24,6 +24,7 @@ Library

24 , conduit >= 0.4 && < 0.5

25 , network-conduit >= 0.4 && < 0.5

26 , blaze-builder-conduit >= 0.4 && < 0.5

27+ , http-conduit >= 1.4 && < 1.5

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

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

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

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

29 , simple-sendfile >= 0.2.2 && < 0.3

30 , simple-sendfile >= 0.2.2 && < 0.3