7fbe13d · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

passing IndexHeader to sendResponse.

7fbe13dKazu Yamamoto13 years ago

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

compare with master

unifiedsplit

@@ -52,6 +52,9 @@ module Network.Wai.Handler.Warp (

52 -- ** Data types

53 , InternalInfo

54 -- ** Request and response

55+ , HeaderValue

56+ , IndexedHeader

57+ , defaultIndexRequestHeader

55 , recvRequest

58 , recvRequest

56 , sendResponse

59 , sendResponse

57#if TEST

60#if TEST

@@ -70,4 +73,5 @@ import Network.Wai.Handler.Warp.Response

70import Network.Wai.Handler.Warp.Run

73import Network.Wai.Handler.Warp.Run

71import Network.Wai.Handler.Warp.Settings

74import Network.Wai.Handler.Warp.Settings

72import Network.Wai.Handler.Warp.Timeout

75import Network.Wai.Handler.Warp.Timeout

73−import Network.Wai.Handler.Warp.Types

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

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

warp/Network/Wai/Handler/Warp/Header.hs+3

@@ -28,6 +28,9 @@ idxHost = 5

28requestMaxIndex :: Int

29requestMaxIndex = 5

31+defaultIndexRequestHeader :: IndexedHeader

32+defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]

33+

31----------------------------------------------------------------

34----------------------------------------------------------------

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

36traverseHeader :: [Header] -> Int -> IndexedHeader

warp/Network/Wai/Handler/Warp/Request.hs+2−1

@@ -43,6 +43,7 @@ recvRequest :: Connection

43 -> SockAddr

44 -> Source IO ByteString

45 -> IO (Request

46+ ,IndexedHeader

46 ,IO (ResumableSource IO ByteString))

47 ,IO (ResumableSource IO ByteString))

47recvRequest conn timeoutHandle addr src0 = do

48recvRequest conn timeoutHandle addr src0 = do

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

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

@@ -67,7 +68,7 @@ recvRequest conn timeoutHandle addr src0 = do

67 , vault = mempty

68 , vault = mempty

68 , requestBodyLength = bodyLength

69 , requestBodyLength = bodyLength

69 }

70 }

70− return (req, getSource)

71+ return (req, idxhdr, getSource)

72----------------------------------------------------------------

73----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Response.hs+26−24

@@ -12,6 +12,7 @@ import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTe

12import Control.Applicative

13import Control.Exception

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

15+import Data.Array ((!))

15import Data.ByteString (ByteString)

16import Data.ByteString (ByteString)

16import qualified Data.ByteString.Char8 as B (pack)

17import qualified Data.ByteString.Char8 as B (pack)

17import qualified Data.CaseInsensitive as CI

18import qualified Data.CaseInsensitive as CI

@@ -20,17 +21,18 @@ import Data.Conduit.Blaze (builderToByteString)

20import qualified Data.Conduit.List as CL

21import qualified Data.Conduit.List as CL

21import Data.Maybe (isJust, listToMaybe)

22import Data.Maybe (isJust, listToMaybe)

22import Data.Monoid (mappend)

23import Data.Monoid (mappend)

24+import Network.HTTP.Attoparsec (parseByteRanges)

23import qualified Network.HTTP.Types as H

25import qualified Network.HTTP.Types as H

24import Network.Wai

26import Network.Wai

25−import Network.Wai.Internal

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

26import Network.Wai.Handler.Warp.ReadInt

28import Network.Wai.Handler.Warp.ReadInt

27−import Network.Wai.Handler.Warp.Settings

28import qualified Network.Wai.Handler.Warp.ResponseHeader as RH

29import qualified Network.Wai.Handler.Warp.ResponseHeader as RH

30+import Network.Wai.Handler.Warp.Settings

29import qualified Network.Wai.Handler.Warp.Timeout as T

31import qualified Network.Wai.Handler.Warp.Timeout as T

30import Network.Wai.Handler.Warp.Types

32import Network.Wai.Handler.Warp.Types

31−import qualified System.PosixCompat.Files as P

33+import Network.Wai.Internal

32−import Network.HTTP.Attoparsec (parseByteRanges)

33import Numeric (showInt)

34import Numeric (showInt)

35+import qualified System.PosixCompat.Files as P

35----------------------------------------------------------------

37----------------------------------------------------------------

36----------------------------------------------------------------

38----------------------------------------------------------------

@@ -38,12 +40,13 @@ import Numeric (showInt)

38sendResponse :: Settings

40sendResponse :: Settings

39 -> InternalInfo -> Request -> Connection

41 -> InternalInfo -> Request -> Connection

40 -> (forall a. IO a -> IO a) -- ^ restore masking state

42 -> (forall a. IO a -> IO a) -- ^ restore masking state

43+ -> IndexedHeader

41 -> Response

44 -> Response

42 -> IO Bool

45 -> IO Bool

44----------------------------------------------------------------

47----------------------------------------------------------------

46−sendResponse settings ii req conn restore (ResponseFile s0 hs0 path mpart0) =

49+sendResponse settings ii req conn restore reqidxhdr (ResponseFile s0 hs0 path mpart0) =

47 restore $ headerAndLength >>= sendResponse'

50 restore $ headerAndLength >>= sendResponse'

48 where

51 where

49 hs = addAccept hs0

52 hs = addAccept hs0

@@ -60,14 +63,13 @@ sendResponse settings ii req conn restore (ResponseFile s0 hs0 path mpart0) =

60 let (s, addRange, beg, end) =

63 let (s, addRange, beg, end) =

61 case mpart0 of

64 case mpart0 of

62 Just part -> (s0, id, filePartOffset part, filePartByteCount part)

65 Just part -> (s0, id, filePartOffset part, filePartByteCount part)

63− Nothing ->

64− case lookup H.hRange (requestHeaders req) >>= parseByteRanges >>= listToMaybe of

66+ Nothing -> case reqidxhdr ! idxRange >>= parseByteRanges >>= listToMaybe of

65− Just range | s0 == H.status200 ->

67+ Just range | s0 == H.status200 ->

66− case range of

68+ case range of

67− H.ByteRangeFrom from -> rangeRes cl from (cl - 1)

69+ H.ByteRangeFrom from -> rangeRes cl from (cl - 1)

68− H.ByteRangeFromTo from to -> rangeRes cl from to

70+ H.ByteRangeFromTo from to -> rangeRes cl from to

69− H.ByteRangeSuffix count -> rangeRes cl (cl - count) (cl - 1)

71+ H.ByteRangeSuffix count -> rangeRes cl (cl - count) (cl - 1)

70− _ -> (s0, id, 0, cl)

72+ _ -> (s0, id, 0, cl)

71 hs'

73 hs'

72 | hadLength = hs

74 | hadLength = hs

73 | otherwise = addLength end hs

75 | otherwise = addLength end hs

@@ -95,16 +97,16 @@ sendResponse settings ii req conn restore (ResponseFile s0 hs0 path mpart0) =

95 return isPersist -- FIXME isKeepAlive?

97 return isPersist -- FIXME isKeepAlive?

96 where

98 where

97 version = httpVersion req

99 version = httpVersion req

98− (isPersist,_) = infoFromRequest req

100+ (isPersist,_) = infoFromRequest req reqidxhdr

101

100 sendResponse' (Left (_ :: SomeException)) =

102 sendResponse' (Left (_ :: SomeException)) =

101− sendResponse settings ii req conn restore notFound

103+ sendResponse settings ii req conn restore reqidxhdr notFound

102 where

104 where

103 notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"

105 notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"

104

106

105----------------------------------------------------------------

107----------------------------------------------------------------

106

108

107−sendResponse settings ii req conn restore (ResponseBuilder s hs b)

109+sendResponse settings ii req conn restore reqidxhdr (ResponseBuilder s hs b)

108 | hasBody s req = restore $ do

110 | hasBody s req = restore $ do

109 header <- composeHeaderBuilder settings version s hs needsChunked

111 header <- composeHeaderBuilder settings version s hs needsChunked

110 let body

112 let body

@@ -122,12 +124,12 @@ sendResponse settings ii req conn restore (ResponseBuilder s hs b)

122 where

124 where

123 th = threadHandle ii

125 th = threadHandle ii

124 version = httpVersion req

126 version = httpVersion req

125− reqinfo@(isPersist,_) = infoFromRequest req

127+ reqinfo@(isPersist,_) = infoFromRequest req reqidxhdr

126 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo

128 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo

127

129

128----------------------------------------------------------------

130----------------------------------------------------------------

129

131

130−sendResponse settings ii req conn restore (ResponseSource s hs withBodyFlush)

132+sendResponse settings ii req conn restore reqidxhdr (ResponseSource s hs withBodyFlush)

131 | hasBody s req = withBodyFlush $ \bodyFlush -> restore $ do

133 | hasBody s req = withBodyFlush $ \bodyFlush -> restore $ do

132 header <- liftIO $ composeHeaderBuilder settings version s hs needsChunked

134 header <- liftIO $ composeHeaderBuilder settings version s hs needsChunked

133 let src = CL.sourceList [header] `mappend` cbody bodyFlush

135 let src = CL.sourceList [header] `mappend` cbody bodyFlush

@@ -152,7 +154,7 @@ sendResponse settings ii req conn restore (ResponseSource s hs withBodyFlush)

152 chunk :: Conduit Builder IO Builder

154 chunk :: Conduit Builder IO Builder

153 chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)

155 chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)

154 version = httpVersion req

156 version = httpVersion req

155− reqinfo@(isPersist,_) = infoFromRequest req

157+ reqinfo@(isPersist,_) = infoFromRequest req reqidxhdr

156 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo

158 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo

157

159

158----------------------------------------------------------------

160----------------------------------------------------------------

@@ -177,16 +179,16 @@ connSink Connection { connSendAll = send } th =

177

179

178----------------------------------------------------------------

180----------------------------------------------------------------

179

181

180−infoFromRequest :: Request -> (Bool,Bool)

182+infoFromRequest :: Request -> IndexedHeader -> (Bool,Bool)

181−infoFromRequest req = (checkPersist req, checkChunk req)

183+infoFromRequest req reqidxhdr = (checkPersist req reqidxhdr, checkChunk req)

182

184

183−checkPersist :: Request -> Bool

185+checkPersist :: Request -> IndexedHeader -> Bool

184−checkPersist req

186+checkPersist req reqidxhdr

185 | ver == H.http11 = checkPersist11 conn

187 | ver == H.http11 = checkPersist11 conn

186 | otherwise = checkPersist10 conn

188 | otherwise = checkPersist10 conn

187 where

189 where

188 ver = httpVersion req

190 ver = httpVersion req

189− conn = lookup H.hConnection $ requestHeaders req

191+ conn = reqidxhdr ! idxConnection

190 checkPersist11 (Just x)

192 checkPersist11 (Just x)

191 | CI.foldCase x == "close" = False

193 | CI.foldCase x == "close" = False

192 checkPersist11 _ = True

194 checkPersist11 _ = True

warp/Network/Wai/Handler/Warp/Run.hs+5−4

@@ -21,13 +21,14 @@ import Network.Socket (accept, SockAddr)

21import qualified Network.Socket.ByteString as Sock

22import Network.Wai

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

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

24import Network.Wai.Handler.Warp.Recv

25import Network.Wai.Handler.Warp.Recv

25import Network.Wai.Handler.Warp.Request

26import Network.Wai.Handler.Warp.Request

26import Network.Wai.Handler.Warp.Response

27import Network.Wai.Handler.Warp.Response

28+import Network.Wai.Handler.Warp.SendFile

27import Network.Wai.Handler.Warp.Settings

29import Network.Wai.Handler.Warp.Settings

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

30import qualified Network.Wai.Handler.Warp.Timeout as T

29import Network.Wai.Handler.Warp.Types

31import Network.Wai.Handler.Warp.Types

30−import Network.Wai.Handler.Warp.SendFile

32#if WINDOWS

33#if WINDOWS

33import qualified Control.Concurrent.MVar as MV

34import qualified Control.Concurrent.MVar as MV

@@ -217,14 +218,14 @@ serveConnection timeoutHandle settings ii app conn remoteHost' =

217 th = threadHandle ii

218 th = threadHandle ii

218

219

219 send500 = void $ mask $ \restore ->

220 send500 = void $ mask $ \restore ->

220− sendResponse settings ii dummyreq conn restore internalError

221+ sendResponse settings ii dummyreq conn restore defaultIndexRequestHeader internalError

221

222

222 dummyreq = defaultRequest { remoteHost = remoteHost' }

223 dummyreq = defaultRequest { remoteHost = remoteHost' }

223

224

224 internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"

225 internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"

225

226

226 serveConnection'' fromClient = do

227 serveConnection'' fromClient = do

227− (env, getSource) <- recvRequest conn timeoutHandle remoteHost' fromClient

228+ (env, idxhdr, getSource) <- recvRequest conn timeoutHandle remoteHost' fromClient

228 case settingsIntercept settings env of

229 case settingsIntercept settings env of

229 Nothing -> do

230 Nothing -> do

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

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

@@ -236,7 +237,7 @@ serveConnection timeoutHandle settings ii app conn remoteHost' =

236 keepAlive <- mask $ \restore -> do

237 keepAlive <- mask $ \restore -> do

237 res <- restore $ app env

238 res <- restore $ app env

238 liftIO $ T.resume th

239 liftIO $ T.resume th

239− sendResponse settings ii env conn restore res

240+ sendResponse settings ii env conn restore idxhdr res

240

241

241 -- We just send a Response and it takes a time to

242 -- We just send a Response and it takes a time to

242 -- receive a Request again. If we immediately call recv,

243 -- receive a Request again. If we immediately call recv,