ba3e2eb · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

introducing indexed header.

ba3e2ebKazu Yamamoto13 years ago

warp/Network/Wai/Handler/Warp/Header.hsnew file+52

compare with master

unifiedsplit

@@ -0,0 +1,52 @@

1+{-# LANGUAGE OverloadedStrings #-}

3+module Network.Wai.Handler.Warp.Header where

5+import Data.Array

6+import Data.Array.ST

7+import Network.HTTP.Types

8+import Network.Wai.Handler.Warp.Types

10+----------------------------------------------------------------

11+

12+type IndexedHeader = Array Int (Maybe HeaderValue)

13+

14+----------------------------------------------------------------

15+

16+indexRequestHeader :: RequestHeaders -> IndexedHeader

17+indexRequestHeader hdr = traverseHeader hdr requestMaxIndex

18+

19+idxContentLength,idxTransferEncoding,idxExpect :: Int

20+idxConnection,idxRange,idxHost :: Int

21+idxContentLength = 0

22+idxTransferEncoding = 1

23+idxExpect = 2

24+idxConnection = 3

25+idxRange = 4

26+idxHost = 5

27+

28+requestMaxIndex :: Int

29+requestMaxIndex = 5

30+

31+----------------------------------------------------------------

32+

33+traverseHeader :: [Header] -> Int -> IndexedHeader

34+traverseHeader hdr maxidx = runSTArray $ do

35+ arr <- newArray (0,maxidx) Nothing

36+ mapM_ (insert arr) hdr

37+ return arr

38+ where

39+ insert arr (key,val)

40+ | idx == -1 = return ()

41+ | otherwise = writeArray arr idx (Just val)

42+ where

43+ idx = keyIndex key

44+

45+keyIndex :: HeaderName -> Int

46+keyIndex "content-length" = idxContentLength

47+keyIndex "transfer-encoding" = idxTransferEncoding

48+keyIndex "expect" = idxExpect

49+keyIndex "connection" = idxConnection

50+keyIndex "range" = idxRange

51+keyIndex "host" = idxHost

52+keyIndex _ = -1

warp/Network/Wai/Handler/Warp/Request.hs+31−25

@@ -10,6 +10,7 @@ module Network.Wai.Handler.Warp.Request (

10import Control.Applicative

11import Control.Exception.Lifted (throwIO)

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

13+import Data.Array ((!))

13import Data.ByteString (ByteString)

14import Data.ByteString (ByteString)

14import qualified Data.ByteString as S

15import qualified Data.ByteString as S

15import qualified Data.ByteString.Unsafe as SU

16import qualified Data.ByteString.Unsafe as SU

@@ -21,6 +22,7 @@ import qualified Network.HTTP.Types as H

21import Network.Socket (SockAddr)

22import Network.Socket (SockAddr)

22import Network.Wai

23import Network.Wai

23import Network.Wai.Handler.Warp.Conduit

24import Network.Wai.Handler.Warp.Conduit

25+import Network.Wai.Handler.Warp.Header

24import Network.Wai.Handler.Warp.ReadInt

26import Network.Wai.Handler.Warp.ReadInt

25import Network.Wai.Handler.Warp.RequestHeader

27import Network.Wai.Handler.Warp.RequestHeader

26import qualified Network.Wai.Handler.Warp.Timeout as Timeout

28import qualified Network.Wai.Handler.Warp.Timeout as Timeout

@@ -43,9 +45,12 @@ recvRequest :: Connection

43 -> IO (Request, IO (ResumableSource IO ByteString))

45 -> IO (Request, IO (ResumableSource IO ByteString))

44recvRequest conn timeoutHandle remoteHost' src0 = do

46recvRequest conn timeoutHandle remoteHost' src0 = do

45 (src, hdrlines) <- src0 $$+ headerLines

47 (src, hdrlines) <- src0 $$+ headerLines

46− (method, rpath, gets, httpversion, hdr') <- parseHeaderLines hdrlines

48+ (method, rpath, gets, httpversion, hdr) <- parseHeaderLines hdrlines

49+ let idxhdr = indexRequestHeader hdr

47− hdr <- liftIO $ handleExpect conn httpversion id hdr'

50+ liftIO $ handleExpect conn httpversion (idxhdr ! idxExpect)

48− (rbody, bodyLength, getSource) <- bodyAndSource src hdr

51+ (rbody, bodyLength, getSource) <- bodyAndSource src

52+ (idxhdr ! idxContentLength)

53+ (idxhdr ! idxTransferEncoding)

50 return (Request

55 return (Request

51 { requestMethod = method

56 { requestMethod = method

@@ -72,41 +77,42 @@ headerLines =

73handleExpect :: Connection

78handleExpect :: Connection

74 -> H.HttpVersion

79 -> H.HttpVersion

75− -> (H.RequestHeaders -> H.RequestHeaders)

80+ -> Maybe HeaderValue

76− -> H.RequestHeaders

81+ -> IO ()

77− -> IO H.RequestHeaders

78−handleExpect _ _ front [] = return $ front []

79−handleExpect conn hv front (("expect", "100-continue"):rest) = do

82+handleExpect conn ver (Just "100-continue") = connSendAll conn continue

80− connSendAll conn $

83+ where

81− if hv == H.http11

84+ continue

82− then "HTTP/1.1 100 Continue\r\n\r\n"

85+ | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n"

83− else "HTTP/1.0 100 Continue\r\n\r\n"

86+ | otherwise = "HTTP/1.0 100 Continue\r\n\r\n"

84− return $ front rest

87+handleExpect _ _ _ = return ()

85−handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs

87----------------------------------------------------------------

89----------------------------------------------------------------

89bodyAndSource :: ResumableSource IO ByteString

91bodyAndSource :: ResumableSource IO ByteString

90− -> H.RequestHeaders

92+ -> Maybe HeaderValue

93+ -> Maybe HeaderValue

91 -> IO (Source IO ByteString

94 -> IO (Source IO ByteString

92 ,RequestBodyLength

95 ,RequestBodyLength

93 ,IO (ResumableSource IO ByteString))

96 ,IO (ResumableSource IO ByteString))

94−bodyAndSource src hdr

97+bodyAndSource src cl te

95 | chunked = do

98 | chunked = do

96 ref <- I.newIORef (src, NeedLen)

99 ref <- I.newIORef (src, NeedLen)

97 return (chunkedSource ref, ChunkedBody, fst <$> I.readIORef ref)

100 return (chunkedSource ref, ChunkedBody, fst <$> I.readIORef ref)

98 | otherwise = do

101 | otherwise = do

99− ibs <- IsolatedBSSource <$> I.newIORef (len0, src)

102+ ibs <- IsolatedBSSource <$> I.newIORef (len, src)

100 return (ibsIsolate ibs, bodyLen, ibsDone ibs)

103 return (ibsIsolate ibs, bodyLen, ibsDone ibs)

101 where

104 where

102− len0 = case lookup H.hContentLength hdr of

105+ len = toLength cl

106+ bodyLen = KnownLength $ fromIntegral len

107+ chunked = isChunked te

108+

109+toLength :: Maybe HeaderValue -> Int

103− Nothing -> 0

110+toLength Nothing = 0

104− Just bs -> readInt bs

111+toLength (Just bs) = readInt bs

105− bodyLen = KnownLength $ fromIntegral len0

112+

106− chunked = isChunked hdr

107−

108−isChunked :: H.RequestHeaders -> Bool

113+isChunked :: Maybe HeaderValue -> Bool

109−isChunked hdr = maybe False ((== "chunked") . CI.foldCase) $ lookup hTransferEncoding hdr

114+isChunked (Just bs) = CI.foldCase bs == "chunked"

115+isChunked _ = False

110

116

111----------------------------------------------------------------

117----------------------------------------------------------------

112

118

warp/Network/Wai/Handler/Warp/RequestHeader.hs+1−1

@@ -3,7 +3,7 @@

3module Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines) where

5import Control.Exception.Lifted (throwIO)

6−import Data.ByteString (ByteString)

6+import Data.ByteString.Char8 (ByteString)

7import qualified Data.ByteString as S

8import qualified Data.ByteString.Char8 as B (unpack)

9import qualified Data.CaseInsensitive as CI

warp/Network/Wai/Handler/Warp/Types.hs+5−3

@@ -8,11 +8,11 @@ import Control.Exception

8import Data.ByteString (ByteString)

9import Data.Typeable (Typeable)

10import Data.Version (showVersion)

11−import Network.Socket (Socket)

12import Network.HTTP.Types.Header

11import Network.HTTP.Types.Header

13−import qualified Paths_warp

12+import Network.Socket (Socket)

14−import qualified Network.Wai.Handler.Warp.Timeout as T

15import qualified Network.Wai.Handler.Warp.FdCache as F

13import qualified Network.Wai.Handler.Warp.FdCache as F

14+import qualified Network.Wai.Handler.Warp.Timeout as T

15+import qualified Paths_warp

17----------------------------------------------------------------

@@ -26,6 +26,8 @@ type Port = Int

27----------------------------------------------------------------

29+type HeaderValue = ByteString

30+

29hTransferEncoding :: HeaderName

31hTransferEncoding :: HeaderName

30hTransferEncoding = "Transfer-Encoding"

32hTransferEncoding = "Transfer-Encoding"

warp/warp.cabal+3

@@ -31,6 +31,7 @@ Flag allow-sendfilefd

32Library

33 Build-Depends: base >= 3 && < 5

34+ , array

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

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

35 , blaze-builder-conduit >= 0.5 && < 1.1

36 , blaze-builder-conduit >= 0.5 && < 1.1

36 , bytestring >= 0.9.1.4

37 , bytestring >= 0.9.1.4

@@ -55,6 +56,7 @@ Library

55 Network.Wai.Handler.Warp.Timeout

56 Network.Wai.Handler.Warp.Timeout

56 Other-modules: Network.Wai.Handler.Warp.Conduit

57 Other-modules: Network.Wai.Handler.Warp.Conduit

57 Network.Wai.Handler.Warp.FdCache

58 Network.Wai.Handler.Warp.FdCache

59+ Network.Wai.Handler.Warp.Header

58 Network.Wai.Handler.Warp.ReadInt

60 Network.Wai.Handler.Warp.ReadInt

59 Network.Wai.Handler.Warp.Recv

61 Network.Wai.Handler.Warp.Recv

60 Network.Wai.Handler.Warp.Request

62 Network.Wai.Handler.Warp.Request

@@ -94,6 +96,7 @@ Test-Suite spec

95 Ghc-Options: -Wall

97 Ghc-Options: -Wall

96 Build-Depends: base >= 4 && < 5

98 Build-Depends: base >= 4 && < 5

99+ , array

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

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

98 , blaze-builder-conduit >= 0.5

101 , blaze-builder-conduit >= 0.5

99 , bytestring >= 0.9.1.4

102 , bytestring >= 0.9.1.4