eada04c · typeable/wai

git.iko.soy/typeable/wai

Merge git://github.com/snoyberg/warp

commiteada04c6335bba73ef50139ca941fe7e5c088ffe authorKazu Yamamoto <kazu@iij.ad.jp> dateTue 19 Jul 2011, 17:26 (15 years ago) parent598d807 a680cca

5 files changed+82−19

compare with master

unifiedsplit

Network/Wai/Handler/Warp.hs+40−15 Timeout.hs+1 pong.hs+5−2 server-no-keepalive.hs+34 warp.cabal+2−2

Network/Wai/Handler/Warp.hs+40−15

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

@@ -61,7 +71,7 @@ import qualified Network.Socket

6171import qualified Network.Socket.ByteString as Sock

6272import Control.Exception

6373 ( bracket, finally, Exception, SomeException, catch

64− , fromException

74+ , fromException, AsyncException (ThreadKilled)

6575 )

6676import Control.Concurrent (forkIO)

6777import qualified Data.Char as C

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

@@ -437,12 +448,17 @@ defaultSettings = Settings

437448 , settingsOnException = \e ->

438449 case fromException e of

439450 Just x -> go x

440− Nothing -> hPutStrLn stderr $ show e

451+ Nothing ->

452+ if go' $ fromException e

453+ then hPutStrLn stderr $ show e

454+ else return ()

441455 , settingsTimeout = 30

442456 }

443457 where

444458 go :: InvalidRequest -> IO ()

445459 go _ = return ()

460+ go' (Just ThreadKilled) = False

461+ go' _ = True

446462

447463takeHeaders :: E.Iteratee ByteString IO [ByteString]

448464takeHeaders = do

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

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

518534readInt :: S.ByteString -> Integer

519535readInt = 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

pong.hs+5−2

@@ -1,6 +1,7 @@

11{-# LANGUAGE OverloadedStrings #-}

22import Network.Wai

33import Network.Wai.Handler.Warp

4+import Network.HTTP.Types (status200)

45import Blaze.ByteString.Builder (copyByteString)

56import Data.Monoid

67import Data.Enumerator (run_, enumList, ($$))

@@ -8,14 +9,14 @@ import Data.Enumerator (run_, enumList, ($$))

89main = run 3000 app

910

1011app req = return $

11− case pathInfo req of

12+ case rawPathInfo req of

1213 "/builder/withlen" -> builderWithLen

1314 "/builder/nolen" -> builderNoLen

1415 "/enum/withlen" -> enumWithLen

1516 "/enum/nolen" -> enumNoLen

1617 "/file/withlen" -> fileWithLen

1718 "/file/nolen" -> fileNoLen

18− _ -> index $ pathInfo req

19+ x -> index x

1920

2021builderWithLen = ResponseBuilder

2122 status200

@@ -36,12 +37,14 @@ fileWithLen = ResponseFile

3637 , ("Content-Length", "4")

3738 ]

3839 "pong.txt"

40+ Nothing

3941

4042fileNoLen = ResponseFile

4143 status200

4244 [ ("Content-Type", "text/plain")

4345 ]

4446 "pong.txt"

47+ Nothing

4548

4649enumWithLen = ResponseEnumerator $ \f ->

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

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+2−2

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

11Name: warp

2−Version: 0.4.0.1

2+Version: 0.4.2

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

44License: BSD3

55License-file: LICENSE

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

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

2525 , simple-sendfile >= 0.1 && < 0.2

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

27− , case-insensitive >= 0.2 && < 0.3

27+ , case-insensitive >= 0.2 && < 0.4

2828 , unix-compat >= 0.2 && < 0.3

2929 if flag(network-bytestring)

3030 build-depends: network >= 2.2.1 && < 2.2.3