git.iko.soy/typeable/wai
on master help sign in
Merge git://github.com/snoyberg/warp
eada04cKazu Yamamoto
Network/Wai/Handler/Warp.hs+40−15
compare with master
unifiedsplit
@@ -37,6 +37,16 @@ module Network.Wai.Handler.Warp
37 -- * Datatypes
37 -- * Datatypes
38 , Port
38 , Port
39 , InvalidRequest (..)
39 , InvalidRequest (..)
40+ -- * Internal
41+ , Manager
42+ , withManager
43+ , parseRequest
44+ , sendResponse
45+ , registerKillThread
46+ , bindPort
47+ , enumSocket
48+ , pause
49+ , resume
40#if TEST
50#if TEST
41 , takeHeaders
51 , takeHeaders
42 , readInt
52 , readInt
@@ -61,7 +71,7 @@ import qualified Network.Socket
61import qualified Network.Socket.ByteString as Sock
71import qualified Network.Socket.ByteString as Sock
62import Control.Exception
72import Control.Exception
63 ( bracket, finally, Exception, SomeException, catch
73 ( bracket, finally, Exception, SomeException, catch
64− , fromException
74+ , fromException, AsyncException (ThreadKilled)
65 )
75 )
66import Control.Concurrent (forkIO)
76import Control.Concurrent (forkIO)
67import qualified Data.Char as C
77import qualified Data.Char as C
@@ -86,6 +96,7 @@ import qualified System.PosixCompat.Files as P
86
96
87import Control.Monad.IO.Class (liftIO)
97import Control.Monad.IO.Class (liftIO)
88import qualified Timeout as T
98import qualified Timeout as T
99+import Timeout (Manager, registerKillThread, pause, resume)
89import Data.Word (Word8)
100import Data.Word (Word8)
90import Data.List (foldl')
101import Data.List (foldl')
91import Control.Monad (forever)
102import Control.Monad (forever)
@@ -173,7 +184,7 @@ serveConnection th onException port app conn remoteHost' = do
173 liftIO $ T.pause th
184 liftIO $ T.pause th
174 res <- E.joinI $ EB.isolate len $$ app env
185 res <- E.joinI $ EB.isolate len $$ app env
175 liftIO $ T.resume th
186 liftIO $ T.resume th
176− keepAlive <- liftIO $ sendResponse th env (httpVersion env) conn res
187+ keepAlive <- liftIO $ sendResponse th env conn res
177 if keepAlive then serveConnection' else return ()
188 if keepAlive then serveConnection' else return ()
178
189
179parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request)
190parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request)
@@ -297,8 +308,8 @@ hasBody :: H.Status -> Request -> Bool
297hasBody s req = s /= (H.Status 204 "") && requestMethod req /= "HEAD"
308hasBody s req = s /= (H.Status 204 "") && requestMethod req /= "HEAD"
298
309
299sendResponse :: T.Handle
310sendResponse :: T.Handle
300− -> Request -> H.HttpVersion -> Socket -> Response -> IO Bool
311+ -> Request -> Socket -> Response -> IO Bool
301−sendResponse th req hv socket (ResponseFile s hs fp mpart) = do
312+sendResponse th req socket (ResponseFile s hs fp mpart) = do
302 (hs', cl) <-
313 (hs', cl) <-
303 case (readInt `fmap` lookup "content-length" hs, mpart) of
314 case (readInt `fmap` lookup "content-length" hs, mpart) of
304 (Just cl, _) -> return (hs, cl)
315 (Just cl, _) -> return (hs, cl)
@@ -308,7 +319,7 @@ sendResponse th req hv socket (ResponseFile s hs fp mpart) = do
308 (Nothing, Just part) -> do
319 (Nothing, Just part) -> do
309 let cl = filePartByteCount part
320 let cl = filePartByteCount part
310 return (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)
321 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
312 if hasBody s req
323 if hasBody s req
313 then do
324 then do
314 case mpart of
325 case mpart of
@@ -323,7 +334,7 @@ sendResponse th req hv socket (ResponseFile s hs fp mpart) = do
323 T.tickle th
334 T.tickle th
324 return True
335 return True
325 else return True
336 else return True
326−sendResponse th req hv socket (ResponseBuilder s hs b)
337+sendResponse th req socket (ResponseBuilder s hs b)
327 | hasBody s req = do
338 | hasBody s req = do
328 toByteStringIO (\bs -> do
339 toByteStringIO (\bs -> do
329 Sock.sendAll socket bs
340 Sock.sendAll socket bs
@@ -333,35 +344,35 @@ sendResponse th req hv socket (ResponseBuilder s hs b)
333 Sock.sendMany socket
344 Sock.sendMany socket
334 $ L.toChunks
345 $ L.toChunks
335 $ toLazyByteString
346 $ toLazyByteString
336− $ headers hv s hs False
347+ $ headers (httpVersion req) s hs False
337 T.tickle th
348 T.tickle th
338 return True
349 return True
339 where
350 where
340− headers' = headers hv s hs isChunked'
351+ headers' = headers (httpVersion req) s hs isChunked'
341 b' = if isChunked'
352 b' = if isChunked'
342 then headers'
353 then headers'
343 `mappend` chunkedTransferEncoding b
354 `mappend` chunkedTransferEncoding b
344 `mappend` chunkedTransferTerminator
355 `mappend` chunkedTransferTerminator
345− else headers hv s hs False `mappend` b
356+ else headers (httpVersion req) s hs False `mappend` b
346 hasLength = lookup "content-length" hs /= Nothing
357 hasLength = lookup "content-length" hs /= Nothing
347− isChunked' = isChunked hv && not hasLength
358+ isChunked' = isChunked (httpVersion req) && not hasLength
348 isKeepAlive = isChunked' || hasLength
359 isKeepAlive = isChunked' || hasLength
349−sendResponse th req hv socket (ResponseEnumerator res) =
360+sendResponse th req socket (ResponseEnumerator res) =
350 res go
361 res go
351 where
362 where
352 -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)
363 -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)
353 go s hs | not (hasBody s req) = do
364 go s hs | not (hasBody s req) = do
354 liftIO $ Sock.sendMany socket
365 liftIO $ Sock.sendMany socket
355 $ L.toChunks $ toLazyByteString
366 $ L.toChunks $ toLazyByteString
356− $ headers hv s hs False
367+ $ headers (httpVersion req) s hs False
357 return True
368 return True
358 go s hs = chunk'
369 go s hs = chunk'
359− $ E.enumList 1 [headers hv s hs isChunked']
370+ $ E.enumList 1 [headers (httpVersion req) s hs isChunked']
360 $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString
371 $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString
361 $$ (iterSocket th socket >> return isKeepAlive)
372 $$ (iterSocket th socket >> return isKeepAlive)
362 where
373 where
363 hasLength = lookup "content-length" hs /= Nothing
374 hasLength = lookup "content-length" hs /= Nothing
364− isChunked' = isChunked hv && not hasLength
375+ isChunked' = isChunked (httpVersion req) && not hasLength
365 isKeepAlive = isChunked' || hasLength
376 isKeepAlive = isChunked' || hasLength
366 chunk' i = if isChunked'
377 chunk' i = if isChunked'
367 then E.joinI $ chunk $$ i
378 then E.joinI $ chunk $$ i
@@ -437,12 +448,17 @@ defaultSettings = Settings
437 , settingsOnException = \e ->
448 , settingsOnException = \e ->
438 case fromException e of
449 case fromException e of
439 Just x -> go x
450 Just x -> go x
451+ Nothing ->
452+ if go' $ fromException e
440− Nothing -> hPutStrLn stderr $ show e
453+ then hPutStrLn stderr $ show e
454+ else return ()
441 , settingsTimeout = 30
455 , settingsTimeout = 30
442 }
456 }
443 where
457 where
444 go :: InvalidRequest -> IO ()
458 go :: InvalidRequest -> IO ()
445 go _ = return ()
459 go _ = return ()
460+ go' (Just ThreadKilled) = False
461+ go' _ = True
446
462
447takeHeaders :: E.Iteratee ByteString IO [ByteString]
463takeHeaders :: E.Iteratee ByteString IO [ByteString]
448takeHeaders = do
464takeHeaders = do
@@ -517,3 +533,12 @@ checkCR bs pos =
517-- invalid content-length is a bad idea, mkay?
533-- invalid content-length is a bad idea, mkay?
518readInt :: S.ByteString -> Integer
534readInt :: S.ByteString -> Integer
519readInt = S.foldl' (\x w -> x * 10 + fromIntegral w - 48) 0
535readInt = 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
17
17
18-- FIXME implement stopManager
18-- FIXME implement stopManager
19
19
20+-- | A timeout manager
20newtype Manager = Manager (I.IORef [Handle])
21newtype Manager = Manager (I.IORef [Handle])
21data Handle = Handle (IO ()) (I.IORef State)
22data Handle = Handle (IO ()) (I.IORef State)
22data State = Active | Inactive | Paused | Canceled
23data State = Active | Inactive | Paused | Canceled
pong.hs+5−2
@@ -1,6 +1,7 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2import Network.Wai
2import Network.Wai
3import Network.Wai.Handler.Warp
3import Network.Wai.Handler.Warp
4+import Network.HTTP.Types (status200)
4import Blaze.ByteString.Builder (copyByteString)
5import Blaze.ByteString.Builder (copyByteString)
5import Data.Monoid
6import Data.Monoid
6import Data.Enumerator (run_, enumList, ($$))
7import Data.Enumerator (run_, enumList, ($$))
@@ -8,14 +9,14 @@ import Data.Enumerator (run_, enumList, ($$))
8main = run 3000 app
9main = run 3000 app
9
10
10app req = return $
11app req = return $
11− case pathInfo req of
12+ case rawPathInfo req of
12 "/builder/withlen" -> builderWithLen
13 "/builder/withlen" -> builderWithLen
13 "/builder/nolen" -> builderNoLen
14 "/builder/nolen" -> builderNoLen
14 "/enum/withlen" -> enumWithLen
15 "/enum/withlen" -> enumWithLen
15 "/enum/nolen" -> enumNoLen
16 "/enum/nolen" -> enumNoLen
16 "/file/withlen" -> fileWithLen
17 "/file/withlen" -> fileWithLen
17 "/file/nolen" -> fileNoLen
18 "/file/nolen" -> fileNoLen
18− _ -> index $ pathInfo req
19+ x -> index x
19
20
20builderWithLen = ResponseBuilder
21builderWithLen = ResponseBuilder
21 status200
22 status200
@@ -36,12 +37,14 @@ fileWithLen = ResponseFile
36 , ("Content-Length", "4")
37 , ("Content-Length", "4")
37 ]
38 ]
38 "pong.txt"
39 "pong.txt"
40+ Nothing
39
41
40fileNoLen = ResponseFile
42fileNoLen = ResponseFile
41 status200
43 status200
42 [ ("Content-Type", "text/plain")
44 [ ("Content-Type", "text/plain")
43 ]
45 ]
44 "pong.txt"
46 "pong.txt"
47+ Nothing
45
48
46enumWithLen = ResponseEnumerator $ \f ->
49enumWithLen = ResponseEnumerator $ \f ->
47 run_ $ (enumList 1 $ map copyByteString ["P", "O", "NG"]) $$ f
50 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 @@
1Name: warp
1Name: warp
2−Version: 0.4.0.1
2+Version: 0.4.2
3Synopsis: A fast, light-weight web server for WAI applications.
3Synopsis: A fast, light-weight web server for WAI applications.
4License: BSD3
4License: BSD3
5License-file: LICENSE
5License-file: LICENSE
@@ -24,7 +24,7 @@ Library
24 , blaze-builder >= 0.2.1.4 && < 0.4
24 , blaze-builder >= 0.2.1.4 && < 0.4
25 , simple-sendfile >= 0.1 && < 0.2
25 , simple-sendfile >= 0.1 && < 0.2
26 , http-types >= 0.6 && < 0.7
26 , http-types >= 0.6 && < 0.7
27− , case-insensitive >= 0.2 && < 0.3
27+ , case-insensitive >= 0.2 && < 0.4
28 , unix-compat >= 0.2 && < 0.3
28 , unix-compat >= 0.2 && < 0.3
29 if flag(network-bytestring)
29 if flag(network-bytestring)
30 build-depends: network >= 2.2.1 && < 2.2.3
30 build-depends: network >= 2.2.1 && < 2.2.3