652a7a0 · typeable/wai

warp/Network/Wai/Handler/Warp.hs+8

compare with master

unifiedsplit

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

40 , setBeforeMainLoop

41 , setNoParsePath

42 , setInstallShutdownHandler

43+ , setServerName

43 -- ** Getters

44 -- ** Getters

44 , getPort

45 , getPort

45 , getHost

46 , getHost

@@ -99,6 +100,7 @@ import Control.Exception (SomeException)

99import Network.Wai (Request, Response)

100import Network.Wai (Request, Response)

100import Network.Socket (SockAddr)

101import Network.Socket (SockAddr)

101import Data.Streaming.Network (HostPreference)

102import Data.Streaming.Network (HostPreference)

103+import Data.ByteString (ByteString)

102

104

103-- | Port to listen on. Default value: 3000

105-- | Port to listen on. Default value: 3000

104--

106--

@@ -202,3 +204,9 @@ getHost = settingsHost

202-- Since 3.0.1

204-- Since 3.0.1

203setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings

205setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings

204setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x }

206setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x }

207+

208+-- | Default server name if application does not set one.

209+--

210+-- Since 3.0.2

211+setServerName :: ByteString -> Settings -> Settings

212+setServerName x y = y { settingsServerName = x }

warp/Network/Wai/Handler/Warp/Response.hs+7−6

@@ -157,14 +157,15 @@ checkPartRange fileSize = checkPart

157-- Typically, Transfer-Encoding: chunked is used.

158-- If Content-Length is specified, Transfer-Encoding: chunked is not used.

159

160+sendResponse :: ByteString -- ^ default server value

160−sendResponse :: Connection

161+ -> Connection

161 -> InternalInfo

162 -> InternalInfo

162 -> Request -- ^ HTTP request.

163 -> Request -- ^ HTTP request.

163 -> IndexedHeader -- ^ Indexed header of HTTP request.

164 -> IndexedHeader -- ^ Indexed header of HTTP request.

164 -> IO ByteString -- ^ source from client, for raw response

165 -> IO ByteString -- ^ source from client, for raw response

165 -> Response -- ^ HTTP response including status code and response header.

166 -> Response -- ^ HTTP response including status code and response header.

166 -> IO Bool -- ^ Returing True if the connection is persistent.

167 -> IO Bool -- ^ Returing True if the connection is persistent.

167−sendResponse conn ii req reqidxhdr src response = do

168+sendResponse defServer conn ii req reqidxhdr src response = do

168 hs <- addServerAndDate hs0

169 hs <- addServerAndDate hs0

169 if hasBody s req then do

170 if hasBody s req then do

170 sendRsp conn ver s hs rsp

171 sendRsp conn ver s hs rsp

@@ -181,7 +182,7 @@ sendResponse conn ii req reqidxhdr src response = do

181 rspidxhdr = indexResponseHeader hs0

182 rspidxhdr = indexResponseHeader hs0

182 th = threadHandle ii

183 th = threadHandle ii

183 dc = dateCacher ii

184 dc = dateCacher ii

184− addServerAndDate = addDate dc rspidxhdr . addServer rspidxhdr

185+ addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr

185 mRange = reqidxhdr ! idxRange

186 mRange = reqidxhdr ! idxRange

186 reqinfo@(isPersist,_) = infoFromRequest req reqidxhdr

187 reqinfo@(isPersist,_) = infoFromRequest req reqidxhdr

187 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr reqinfo

188 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr reqinfo

@@ -389,9 +390,9 @@ warpVersion = showVersion Paths_warp.version

389defaultServerValue :: HeaderValue

390defaultServerValue :: HeaderValue

390defaultServerValue = B.pack $ "Warp/" ++ warpVersion

391defaultServerValue = B.pack $ "Warp/" ++ warpVersion

391

392

392−addServer :: IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders

393+addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders

393−addServer rspidxhdr hdrs = case rspidxhdr ! idxServer of

394+addServer defaultServerValue' rspidxhdr hdrs = case rspidxhdr ! idxServer of

394− Nothing -> (hServer, defaultServerValue) : hdrs

395+ Nothing -> (hServer, defaultServerValue') : hdrs

395 _ -> hdrs

396 _ -> hdrs

396

397

397----------------------------------------------------------------

398----------------------------------------------------------------

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

@@ -284,7 +284,9 @@ serveConnection conn ii addr isSecure' settings app = do

284 sendErrorResponse istatus e = do

285 status <- readIORef istatus

286 when status $ void $

287+ sendResponse

288+ (settingsServerName settings)

287− sendResponse conn ii dummyreq defaultIndexRequestHeader (return S.empty) (errorResponse e)

289+ conn ii dummyreq defaultIndexRequestHeader (return S.empty) (errorResponse e)

288

290

289 dummyreq = defaultRequest { remoteHost = addr }

291 dummyreq = defaultRequest { remoteHost = addr }

290

292

@@ -306,7 +308,9 @@ serveConnection conn ii addr isSecure' settings app = do

306 -- send more meaningful error messages to the user.

308 -- send more meaningful error messages to the user.

307 -- However, it may affect performance.

309 -- However, it may affect performance.

308 writeIORef istatus False

310 writeIORef istatus False

311+ keepAlive <- sendResponse

312+ (settingsServerName settings)

309− keepAlive <- sendResponse conn ii req idxhdr (readSource fromClient) res

313+ conn ii req idxhdr (readSource fromClient) res

310 writeIORef keepAliveRef keepAlive

314 writeIORef keepAliveRef keepAlive

311 return ResponseReceived

315 return ResponseReceived

312 keepAlive <- readIORef keepAliveRef

316 keepAlive <- readIORef keepAliveRef

warp/Network/Wai/Handler/Warp/Settings.hs+9

@@ -18,6 +18,10 @@ import System.IO (stderr)

18import System.IO.Error (ioeGetErrorType)

19import qualified Data.Text.Lazy as TL

20import qualified Data.Text.Lazy.Encoding as TLE

21+import Data.ByteString (ByteString)

22+import qualified Data.ByteString.Char8 as S8

23+import Data.Version (showVersion)

24+import qualified Paths_warp

21

25

22-- | Various Warp server settings. This is purposely kept as an abstract data

26-- | Various Warp server settings. This is purposely kept as an abstract data

23-- type so that new settings can be added without breaking backwards

27-- type so that new settings can be added without breaking backwards

@@ -57,6 +61,10 @@ data Settings = Settings

57 --

61 --

58 -- Since 2.0.3

62 -- Since 2.0.3

59 , settingsInstallShutdownHandler :: IO () -> IO ()

63 , settingsInstallShutdownHandler :: IO () -> IO ()

64+ , settingsServerName :: ByteString

65+ -- ^ Default server name if application does not set one.

66+ --

67+ -- Since 3.0.2

60 }

68 }

61

69

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

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

@@ -75,6 +83,7 @@ defaultSettings = Settings

75 , settingsBeforeMainLoop = return ()

83 , settingsBeforeMainLoop = return ()

76 , settingsNoParsePath = False

84 , settingsNoParsePath = False

77 , settingsInstallShutdownHandler = const $ return ()

85 , settingsInstallShutdownHandler = const $ return ()

86+ , settingsServerName = S8.pack $ "Warp/" ++ showVersion Paths_warp.version

78 }

87 }

79

88

80-- | Apply the logic provided by 'defaultExceptionHandler' to determine if an

89-- | Apply the logic provided by 'defaultExceptionHandler' to determine if an

warp/warp.cabal+1−1

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

1Name: warp

2−Version: 3.0.1.1

2+Version: 3.0.2

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

4License: MIT

5License-file: LICENSE