69cdd06 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

removing settingsServerName.

69cdd06Kazu Yamamoto13 years ago

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

compare with master

unifiedsplit

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

36 , settingsManager

37 , settingsFdCacheDuration

38 , settingsBeforeMainLoop

39− , settingsServerName

40 -- * Data types

39 -- * Data types

41 , HostPreference (..)

40 , HostPreference (..)

42 , Port

41 , Port

warp/Network/Wai/Handler/Warp/Response.hs+23−30

@@ -27,7 +27,6 @@ import Network.Wai

27import Network.Wai.Handler.Warp.Header

28import Network.Wai.Handler.Warp.ReadInt

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

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

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

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

32import Network.Wai.Handler.Warp.Types

31import Network.Wai.Handler.Warp.Types

33import Network.Wai.Internal

32import Network.Wai.Internal

@@ -37,8 +36,7 @@ import qualified System.PosixCompat.Files as P

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

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

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

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

40−sendResponse :: Settings

41− -> InternalInfo -> Request -> Connection

39+sendResponse :: InternalInfo -> Request -> Connection

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

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

43 -> IndexedHeader

41 -> IndexedHeader

44 -> Response

42 -> Response

@@ -46,7 +44,7 @@ sendResponse :: Settings

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

45----------------------------------------------------------------

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

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

50 restore $ headerAndLength >>= sendResponse'

48 restore $ headerAndLength >>= sendResponse'

51 where

49 where

52 hs = addAccept hs0

50 hs = addAccept hs0

@@ -87,12 +85,12 @@ sendResponse settings ii req conn restore reqidxhdr (ResponseFile s0 hs0 path mp

88 sendResponse' (Right (s, lengthyHeaders, beg, len))

86 sendResponse' (Right (s, lengthyHeaders, beg, len))

89 | hasBody s req = liftIO $ do

87 | hasBody s req = liftIO $ do

90− lheader <- composeHeader settings version s lengthyHeaders

88+ lheader <- composeHeader version s lengthyHeaders

91 connSendFile conn path beg len (T.tickle th) [lheader]

89 connSendFile conn path beg len (T.tickle th) [lheader]

92 T.tickle th

90 T.tickle th

93 return isPersist

91 return isPersist

94 | otherwise = liftIO $ do

92 | otherwise = liftIO $ do

95− composeHeader settings version s hs >>= connSendAll conn

93+ composeHeader version s hs >>= connSendAll conn

96 T.tickle th

94 T.tickle th

97 return isPersist -- FIXME isKeepAlive?

95 return isPersist -- FIXME isKeepAlive?

98 where

96 where

@@ -100,15 +98,15 @@ sendResponse settings ii req conn restore reqidxhdr (ResponseFile s0 hs0 path mp

100 (isPersist,_) = infoFromRequest req reqidxhdr

98 (isPersist,_) = infoFromRequest req reqidxhdr

101

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

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

103− sendResponse settings ii req conn restore reqidxhdr notFound

101+ sendResponse ii req conn restore reqidxhdr notFound

104 where

102 where

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

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

106

104

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

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

108

106

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

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

110 | hasBody s req = restore $ do

108 | hasBody s req = restore $ do

111− header <- composeHeaderBuilder settings version s hs needsChunked

109+ header <- composeHeaderBuilder version s hs needsChunked

112 let body

110 let body

113 | needsChunked = header `mappend` chunkedTransferEncoding b

111 | needsChunked = header `mappend` chunkedTransferEncoding b

114 `mappend` chunkedTransferTerminator

112 `mappend` chunkedTransferTerminator

@@ -118,7 +116,7 @@ sendResponse settings ii req conn restore reqidxhdr (ResponseBuilder s hs b)

118 T.tickle th

116 T.tickle th

119 return isKeepAlive

117 return isKeepAlive

120 | otherwise = restore $ do

118 | otherwise = restore $ do

121− composeHeader settings version s hs >>= connSendAll conn

119+ composeHeader version s hs >>= connSendAll conn

122 T.tickle th

120 T.tickle th

123 return isPersist

121 return isPersist

124 where

122 where

@@ -129,14 +127,14 @@ sendResponse settings ii req conn restore reqidxhdr (ResponseBuilder s hs b)

129

127

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

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

131

129

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

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

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

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

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

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

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

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

136 src $$ builderToByteString =$ connSink conn th

134 src $$ builderToByteString =$ connSink conn th

137 return isKeepAlive

135 return isKeepAlive

138 | otherwise = withBodyFlush $ \_bodyFlush -> restore $ do -- make sure any cleanup is called

136 | otherwise = withBodyFlush $ \_bodyFlush -> restore $ do -- make sure any cleanup is called

139− composeHeader settings version s hs >>= connSendAll conn

137+ composeHeader version s hs >>= connSendAll conn

140 T.tickle th

138 T.tickle th

141 return isPersist

139 return isPersist

142 where

140 where

@@ -231,27 +229,22 @@ addAccept hdrs = (hAcceptRanges, "bytes") : hdrs

231addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders

229addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders

232addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs

230addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs

233

231

234−addServerHeader :: Settings -> H.ResponseHeaders -> H.ResponseHeaders

232+addServerHeader :: H.ResponseHeaders -> H.ResponseHeaders

235−addServerHeader settings hdrs = case lookup hServer hdrs of

233+addServerHeader hdrs = case lookup hServer hdrs of

236− Nothing -> warpVersionHeader settings : hdrs

234+ Nothing -> (hServer, defaultServerValue) : hdrs

237 Just _ -> hdrs

235 Just _ -> hdrs

238

236

239−warpVersionHeader :: Settings -> H.Header

240−warpVersionHeader settings = (hServer, settingsServerName settings)

241−

242----------------------------------------------------------------

237----------------------------------------------------------------

243

238

244−composeHeader :: Settings

245− -> H.HttpVersion

239+composeHeader :: H.HttpVersion

246 -> H.Status

240 -> H.Status

247 -> H.ResponseHeaders

241 -> H.ResponseHeaders

248 -> IO ByteString

242 -> IO ByteString

249−composeHeader settings version s hs =

243+composeHeader version s hs =

250− RH.composeHeader version s

244+ RH.composeHeader version s $ addServerHeader hs

251− $ addServerHeader settings hs

245+

252−

253−composeHeaderBuilder :: Settings -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder

246+composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder

254−composeHeaderBuilder settings ver s hs True =

247+composeHeaderBuilder ver s hs True =

255− fromByteString <$> composeHeader settings ver s (addEncodingHeader hs)

248+ fromByteString <$> composeHeader ver s (addEncodingHeader hs)

256−composeHeaderBuilder settings ver s hs False =

249+composeHeaderBuilder ver s hs False =

257− fromByteString <$> composeHeader settings ver s hs

250+ fromByteString <$> composeHeader ver s hs

warp/Network/Wai/Handler/Warp/Run.hs+2−2

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

218 th = threadHandle ii

219

220 send500 = void $ mask $ \restore ->

221− sendResponse settings ii dummyreq conn restore defaultIndexRequestHeader internalError

221+ sendResponse ii dummyreq conn restore defaultIndexRequestHeader internalError

222

223 dummyreq = defaultRequest { remoteHost = remoteHost' }

224

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

237 keepAlive <- mask $ \restore -> do

238 res <- restore $ app env

239 liftIO $ T.resume th

240− sendResponse settings ii env conn restore idxhdr res

240+ sendResponse ii env conn restore idxhdr res

241

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

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

warp/Network/Wai/Handler/Warp/Settings.hs−8

@@ -2,7 +2,6 @@ module Network.Wai.Handler.Warp.Settings where

3import Control.Exception

4import qualified Data.ByteString as S

5−import qualified Data.ByteString.Char8 as S8

6import Data.Conduit

5import Data.Conduit

7import Data.Conduit.Network (HostPreference (HostIPv4))

6import Data.Conduit.Network (HostPreference (HostIPv4))

8import GHC.IO.Exception (IOErrorType(..))

7import GHC.IO.Exception (IOErrorType(..))

@@ -36,12 +35,6 @@ data Settings = Settings

36 -- Default: do nothing.

35 -- Default: do nothing.

37 --

36 --

38 -- Since 1.3.6

37 -- Since 1.3.6

39− , settingsServerName :: S.ByteString

40− -- ^ Server name to be sent in the Server header.

41− --

42− -- Default: Warp\//version/

43− --

44− -- Since 1.3.8

45 }

38 }

47-- | The default settings for the Warp server. See the individual settings for

40-- | The default settings for the Warp server. See the individual settings for

@@ -58,7 +51,6 @@ defaultSettings = Settings

58 , settingsManager = Nothing

51 , settingsManager = Nothing

59 , settingsFdCacheDuration = 10

52 , settingsFdCacheDuration = 10

60 , settingsBeforeMainLoop = return ()

53 , settingsBeforeMainLoop = return ()

61− , settingsServerName = S8.pack $ "Warp/" ++ warpVersion

62 }

54 }

64defaultExceptionHandler :: Maybe Request -> SomeException -> IO ()

56defaultExceptionHandler :: Maybe Request -> SomeException -> IO ()

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

@@ -5,7 +5,7 @@

5module Network.Wai.Handler.Warp.Types where

7import Control.Exception

8−import Data.ByteString (ByteString)

8+import Data.ByteString.Char8 (ByteString, pack)

9import Data.Typeable (Typeable)

10import Data.Version (showVersion)

11import Network.HTTP.Types.Header

@@ -33,11 +33,14 @@ type HeaderValue = ByteString

33hTransferEncoding :: HeaderName

34hTransferEncoding = "Transfer-Encoding"

36+hAcceptRanges :: HeaderName

37+hAcceptRanges = "Accept-Ranges"

38+

36hServer :: HeaderName

39hServer :: HeaderName

37hServer = "Server"

40hServer = "Server"

39−hAcceptRanges :: HeaderName

42+defaultServerValue :: HeaderValue

40−hAcceptRanges = "Accept-Ranges"

43+defaultServerValue = pack $ "Warp/" ++ warpVersion

42----------------------------------------------------------------

45----------------------------------------------------------------