a680cca · typeable/wai

git.iko.soy/typeable/wai

Expose internals

commita680cca0be5954eb443a6f3d04c3bebbde892609 authorMichael Snoyman <michael@snoyman.com> dateFri 15 Jul 2011, 10:17 (15 years ago) parent0ad661e

4 files changed+69−14

compare with master

unifiedsplit

Network/Wai/Handler/Warp.hs+33−13 Timeout.hs+1 server-no-keepalive.hs+34 warp.cabal+1−1

Network/Wai/Handler/Warp.hs+33−13

@@ -37,6 +37,16 @@ module Network.Wai.Handler.Warp

3737 -- * Datatypes

3838 , Port

3939 , InvalidRequest (..)

40+ -- * Internal

41+ , Manager

42+ , withManager

43+ , parseRequest

44+ , sendResponse

45+ , registerKillThread

46+ , bindPort

47+ , enumSocket

48+ , pause

49+ , resume

4050#if TEST

4151 , takeHeaders

4252 , readInt

@@ -86,6 +96,7 @@ import qualified System.PosixCompat.Files as P

8696

8797import Control.Monad.IO.Class (liftIO)

8898import qualified Timeout as T

99+import Timeout (Manager, registerKillThread, pause, resume)

89100import Data.Word (Word8)

90101import Data.List (foldl')

91102import Control.Monad (forever)

@@ -173,7 +184,7 @@ serveConnection th onException port app conn remoteHost' = do

173184 liftIO $ T.pause th

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

175186 liftIO $ T.resume th

176− keepAlive <- liftIO $ sendResponse th env (httpVersion env) conn res

187+ keepAlive <- liftIO $ sendResponse th env conn res

177188 if keepAlive then serveConnection' else return ()

178189

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

@@ -297,8 +308,8 @@ hasBody :: H.Status -> Request -> Bool

297308hasBody s req = s /= (H.Status 204 "") && requestMethod req /= "HEAD"

298309

299310sendResponse :: T.Handle

300− -> Request -> H.HttpVersion -> Socket -> Response -> IO Bool

301−sendResponse th req hv socket (ResponseFile s hs fp mpart) = do

311+ -> Request -> Socket -> Response -> IO Bool

312+sendResponse th req socket (ResponseFile s hs fp mpart) = do

302313 (hs', cl) <-

303314 case (readInt `fmap` lookup "content-length" hs, mpart) of

304315 (Just cl, _) -> return (hs, cl)

@@ -308,7 +319,7 @@ sendResponse th req hv socket (ResponseFile s hs fp mpart) = do

308319 (Nothing, Just part) -> do

309320 let cl = filePartByteCount part

310321 return (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)

311− Sock.sendMany socket $ L.toChunks $ toLazyByteString $ headers hv s hs' False

322+ Sock.sendMany socket $ L.toChunks $ toLazyByteString $ headers (httpVersion req) s hs' False

312323 if hasBody s req

313324 then do

314325 case mpart of

@@ -323,7 +334,7 @@ sendResponse th req hv socket (ResponseFile s hs fp mpart) = do

323334 T.tickle th

324335 return True

325336 else return True

326−sendResponse th req hv socket (ResponseBuilder s hs b)

337+sendResponse th req socket (ResponseBuilder s hs b)

327338 | hasBody s req = do

328339 toByteStringIO (\bs -> do

329340 Sock.sendAll socket bs

@@ -333,35 +344,35 @@ sendResponse th req hv socket (ResponseBuilder s hs b)

333344 Sock.sendMany socket

334345 $ L.toChunks

335346 $ toLazyByteString

336− $ headers hv s hs False

347+ $ headers (httpVersion req) s hs False

337348 T.tickle th

338349 return True

339350 where

340− headers' = headers hv s hs isChunked'

351+ headers' = headers (httpVersion req) s hs isChunked'

341352 b' = if isChunked'

342353 then headers'

343354 `mappend` chunkedTransferEncoding b

344355 `mappend` chunkedTransferTerminator

345− else headers hv s hs False `mappend` b

356+ else headers (httpVersion req) s hs False `mappend` b

346357 hasLength = lookup "content-length" hs /= Nothing

347− isChunked' = isChunked hv && not hasLength

358+ isChunked' = isChunked (httpVersion req) && not hasLength

348359 isKeepAlive = isChunked' || hasLength

349−sendResponse th req hv socket (ResponseEnumerator res) =

360+sendResponse th req socket (ResponseEnumerator res) =

350361 res go

351362 where

352363 -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)

353364 go s hs | not (hasBody s req) = do

354365 liftIO $ Sock.sendMany socket

355366 $ L.toChunks $ toLazyByteString

356− $ headers hv s hs False

367+ $ headers (httpVersion req) s hs False

357368 return True

358369 go s hs = chunk'

359− $ E.enumList 1 [headers hv s hs isChunked']

370+ $ E.enumList 1 [headers (httpVersion req) s hs isChunked']

360371 $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString

361372 $$ (iterSocket th socket >> return isKeepAlive)

362373 where

363374 hasLength = lookup "content-length" hs /= Nothing

364− isChunked' = isChunked hv && not hasLength

375+ isChunked' = isChunked (httpVersion req) && not hasLength

365376 isKeepAlive = isChunked' || hasLength

366377 chunk' i = if isChunked'

367378 then E.joinI $ chunk $$ i

@@ -522,3 +533,12 @@ checkCR bs pos =

522533-- invalid content-length is a bad idea, mkay?

523534readInt :: S.ByteString -> Integer

524535readInt = S.foldl' (\x w -> x * 10 + fromIntegral w - 48) 0

536+

537+-- | Call the inner function with a timeout manager.

538+withManager :: Int -- ^ timeout in microseconds

539+ -> (Manager -> IO a)

540+ -> IO a

541+withManager timeout f = do

542+ -- FIXME when stopManager is available, use it

543+ man <- T.initialize timeout

544+ f man

Timeout.hs+1

@@ -17,6 +17,7 @@ import qualified Control.Exception as E

1717

1818-- FIXME implement stopManager

1919

20+-- | A timeout manager

2021newtype Manager = Manager (I.IORef [Handle])

2122data Handle = Handle (IO ()) (I.IORef State)

2223data State = Active | Inactive | Paused | Canceled

server-no-keepalive.hsnew file+34

@@ -0,0 +1,34 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai.Handler.Warp

3+import Control.Exception (bracket)

4+import Control.Monad (forever)

5+import Network (sClose)

6+import Network.Socket (accept)

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

8+import qualified Data.Enumerator as E

9+import qualified Data.Enumerator.Binary as EB

10+import Control.Concurrent (forkIO)

11+import Network.Wai (responseLBS)

12+import Network.HTTP.Types (status200)

13+import Data.Enumerator (($$), run_)

14+

15+app = const $ return $ responseLBS status200 [("Content-type", "text/plain")] "This is not kept alive under any circumtances"

16+

17+main = withManager 30000000 $ \man -> bracket

18+ (bindPort (settingsPort set) (settingsHost set))

19+ sClose

20+ (\socket -> forever $ do

21+ (conn, sa) <- accept socket

22+ th <- liftIO $ registerKillThread man

23+ _ <- forkIO $ do

24+ run_ $ enumSocket th 4096 conn $$ do

25+ liftIO $ pause th

26+ (len, env) <- parseRequest (settingsPort set) sa

27+ liftIO $ resume th

28+ res <- E.joinI $ EB.isolate len $$ app env

29+ _ <- liftIO $ sendResponse th env conn res

30+ liftIO $ sClose conn

31+ return ()

32+ )

33+ where

34+ set = defaultSettings

warp.cabal+1−1

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

11Name: warp

2−Version: 0.4.1.2

2+Version: 0.4.2

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

44License: BSD3

55License-file: LICENSE