@@ -21,6 +21,7 @@ import Data.Monoid (mappend)
2121import qualified Network.HTTP.Types as H
2222import Network.Wai
2323import Network.Wai.Handler.Warp.ReadInt
24+import Network.Wai.Handler.Warp.Settings
2425import qualified Network.Wai.Handler.Warp.ResponseHeader as RH
2526import qualified Network.Wai.Handler.Warp.Timeout as T
2627import Network.Wai.Handler.Warp.Types
@@ -29,12 +30,13 @@ import qualified System.PosixCompat.Files as P
2930----------------------------------------------------------------
3031----------------------------------------------------------------
3132
32−sendResponse :: Cleaner -> Request -> Connection -> Response
33+sendResponse :: Settings
34+ -> Cleaner -> Request -> Connection -> Response
3335 -> ResourceT IO Bool
3436
3537----------------------------------------------------------------
3638
37−sendResponse cleaner req conn (ResponseFile s hs path mpart) =
39+sendResponse settings cleaner req conn (ResponseFile s hs path mpart) =
3840 headerAndLength >>= sendResponse'
3941 where
4042 th = threadHandle cleaner
@@ -49,12 +51,12 @@ sendResponse cleaner req conn (ResponseFile s hs path mpart) =
4951
5052 sendResponse' (Right (lengthyHeaders, cl))
5153 | hasBody s req = liftIO $ do
52− lheader <- composeHeader version s lengthyHeaders
54+ lheader <- composeHeader settings version s lengthyHeaders
5355 connSendFile conn path beg end (T.tickle th) [lheader] cleaner
5456 T.tickle th
5557 return isPersist
5658 | otherwise = liftIO $ do
57− composeHeader version s hs >>= connSendAll conn
59+ composeHeader settings version s hs >>= connSendAll conn
5860 T.tickle th
5961 return isPersist -- FIXME isKeepAlive?
6062 where
@@ -65,15 +67,15 @@ sendResponse cleaner req conn (ResponseFile s hs path mpart) =
6567 (isPersist,_) = infoFromRequest req
6668
6769 sendResponse' (Left (_ :: SomeException)) =
68− sendResponse cleaner req conn notFound
70+ sendResponse settings cleaner req conn notFound
6971 where
7072 notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"
7173
7274----------------------------------------------------------------
7375
74−sendResponse cleaner req conn (ResponseBuilder s hs b)
76+sendResponse settings cleaner req conn (ResponseBuilder s hs b)
7577 | hasBody s req = liftIO $ do
76− header <- composeHeaderBuilder version s hs needsChunked
78+ header <- composeHeaderBuilder settings version s hs needsChunked
7779 let body
7880 | needsChunked = header `mappend` chunkedTransferEncoding b
7981 `mappend` chunkedTransferTerminator
@@ -83,7 +85,7 @@ sendResponse cleaner req conn (ResponseBuilder s hs b)
8385 T.tickle th
8486 return isKeepAlive
8587 | otherwise = liftIO $ do
86− composeHeader version s hs >>= connSendAll conn
88+ composeHeader settings version s hs >>= connSendAll conn
8789 T.tickle th
8890 return isPersist
8991 where
@@ -94,14 +96,14 @@ sendResponse cleaner req conn (ResponseBuilder s hs b)
9496
9597----------------------------------------------------------------
9698
97−sendResponse cleaner req conn (ResponseSource s hs bodyFlush)
99+sendResponse settings cleaner req conn (ResponseSource s hs bodyFlush)
98100 | hasBody s req = do
99− header <- liftIO $ composeHeaderBuilder version s hs needsChunked
101+ header <- liftIO $ composeHeaderBuilder settings version s hs needsChunked
100102 let src = CL.sourceList [header] `mappend` cbody
101103 src $$ builderToByteString =$ connSink conn th
102104 return isKeepAlive
103105 | otherwise = liftIO $ do
104− composeHeader version s hs >>= connSendAll conn
106+ composeHeader settings version s hs >>= connSendAll conn
105107 T.tickle th
106108 return isPersist
107109 where
@@ -193,23 +195,27 @@ addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
193195addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders
194196addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs
195197
196−addServerHeader :: H.ResponseHeaders -> H.ResponseHeaders
197−addServerHeader hdrs = case lookup hServer hdrs of
198− Nothing -> warpVersionHeader : hdrs
198+addServerHeader :: Settings -> H.ResponseHeaders -> H.ResponseHeaders
199+addServerHeader settings hdrs = case lookup hServer hdrs of
200+ Nothing -> warpVersionHeader settings : hdrs
199201 Just _ -> hdrs
200202
201−warpVersionHeader :: H.Header
202−warpVersionHeader = (hServer, ver)
203− where
204− ver = B.pack $ "Warp/" ++ warpVersion
203+warpVersionHeader :: Settings -> H.Header
204+warpVersionHeader settings = (hServer, settingsServerName settings)
205205
206206----------------------------------------------------------------
207207
208−composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString
209−composeHeader version s hs = RH.composeHeader version s (addServerHeader hs)
210−
211−composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
212−composeHeaderBuilder ver s hs True =
213− fromByteString <$> composeHeader ver s (addEncodingHeader hs)
214−composeHeaderBuilder ver s hs False =
215− fromByteString <$> composeHeader ver s hs
208+composeHeader :: Settings
209+ -> H.HttpVersion
210+ -> H.Status
211+ -> H.ResponseHeaders
212+ -> IO ByteString
213+composeHeader settings version s hs =
214+ RH.composeHeader version s
215+ $ addServerHeader settings hs
216+
217+composeHeaderBuilder :: Settings -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
218+composeHeaderBuilder settings ver s hs True =
219+ fromByteString <$> composeHeader settings ver s (addEncodingHeader hs)
220+composeHeaderBuilder settings ver s hs False =
221+ fromByteString <$> composeHeader settings ver s hs