f3c26ad · typeable/wai

git.iko.soy/typeable/wai

Merge branch for #468.

commitf3c26ad55d3443e784dc00f265f9dd903e2a522b authorKazu Yamamoto <kazu@iij.ad.jp> dateTue 24 Nov 2015, 13:16 (11 years ago) parent0f54dc3 0297412

5 files changed+59−20

compare with master

unifiedsplit

warp/Network/Wai/Handler/Warp/Response.hs+23−20 warp/test/HTTP.hs+9 warp/test/RunSpec.hs+25 warp/test/head-response+1 warp/warp.cabal+1

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

@@ -154,7 +154,11 @@ sendResponse :: ByteString -- ^ default server value

154154sendResponse defServer conn ii req reqidxhdr src response = do

155155 hs <- addServerAndDate hs0

156156 if hasBody s then do

157− -- HEAD comes here even if it does not have body.

157+ -- HEAD comes here even if it does not have body. We include HEAD

158+ -- responses here so that we generate appropriate content-length

159+ -- headers below.

160+ --

161+ -- See definition of rsp below for proper body stripping.

158162 sendRsp conn mfdc ver s hs rsp

159163 T.tickle th

160164 return ret

@@ -176,8 +180,10 @@ sendResponse defServer conn ii req reqidxhdr src response = do

176180 isChunked = not isHead && isChunked0

177181 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)

178182 isHead = requestMethod req == H.methodHead

179− rsp = case response of

180− ResponseFile _ _ path mPart -> RspFile path mPart mRange isHead (T.tickle th)

183+ rsp

184+ | isHead = RspBuilder mempty False

185+ | otherwise = case response of

186+ ResponseFile _ _ path mPart -> RspFile path mPart mRange (T.tickle th)

181187 ResponseBuilder _ _ b -> RspBuilder b needsChunked

182188 ResponseStream _ _ fb -> RspStream fb needsChunked th

183189 ResponseRaw raw _ -> RspRaw raw src (T.tickle th)

@@ -214,7 +220,7 @@ sanitizeHeaderValue v = case S8.lines $ S.filter (/= _cr) v of

214220

215221----------------------------------------------------------------

216222

217−data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) Bool (IO ())

223+data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) (IO ())

218224 | RspBuilder Builder Bool

219225 | RspStream StreamingBody Bool T.Handle

220226 | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())

@@ -228,7 +234,7 @@ sendRsp :: Connection

228234 -> H.ResponseHeaders

229235 -> Rsp

230236 -> IO ()

231−sendRsp conn mfdc ver s0 hs0 (RspFile path mPart mRange isHead hook) = do

237+sendRsp conn mfdc ver s0 hs0 (RspFile path mPart mRange hook) = do

232238 ex <- fileRange s0 hs0 path mPart mRange

233239 case ex of

234240 Left _ex ->

@@ -237,24 +243,21 @@ sendRsp conn mfdc ver s0 hs0 (RspFile path mPart mRange isHead hook) = do

237243#endif

238244 sendRsp conn mfdc ver s2 hs2 (RspBuilder body True)

239245 Right (s, hs, beg, len)

240− | len >= 0 ->

241− if isHead then

242− sendRsp conn mfdc ver s hs (RspBuilder mempty False)

243− else do

244− lheader <- composeHeader ver s hs

246+ | len >= 0 -> do

247+ lheader <- composeHeader ver s hs

245248#ifdef WINDOWS

246− let fid = FileId path Nothing

247− hook' = hook

249+ let fid = FileId path Nothing

250+ hook' = hook

248251#else

249− (mfd, hook') <- case mfdc of

250− -- settingsFdCacheDuration is 0

251− Nothing -> return (Nothing, hook)

252− Just fdc -> do

253− (fd, fresher) <- F.getFd fdc path

254− return (Just fd, hook >> fresher)

255− let fid = FileId path mfd

252+ (mfd, hook') <- case mfdc of

253+ -- settingsFdCacheDuration is 0

254+ Nothing -> return (Nothing, hook)

255+ Just fdc -> do

256+ (fd, fresher) <- F.getFd fdc path

257+ return (Just fd, hook >> fresher)

258+ let fid = FileId path mfd

256259#endif

257− connSendFile conn fid beg len hook' [lheader]

260+ connSendFile conn fid beg len hook' [lheader]

258261 | otherwise ->

259262 sendRsp conn mfdc ver H.status416

260263 (filter (\(k, _) -> k /= "content-length") hs)

warp/test/HTTP.hs+9

@@ -3,11 +3,14 @@

33module HTTP (

44 sendGET

55 , sendGETwH

6+ , sendHEAD

7+ , sendHEADwH

68 , rspBody

79 , rspCode

810 , rspHeaders

911 , getHeaderValue

1012 , HeaderName(..)

13+ , mkHeader

1114 ) where

1215

1316import Network.HTTP

@@ -19,6 +22,12 @@ sendGET url = sendGETwH url []

1922sendGETwH :: String -> [Header] -> IO (Response String)

2023sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }

2124

25+sendHEAD :: String -> IO (Response String)

26+sendHEAD url = sendHEADwH url []

27+

28+sendHEADwH :: String -> [Header] -> IO (Response String)

29+sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url) { rqHeaders = hdr }

30+

2231unResult :: IO (Result (Response String)) -> IO (Response String)

2332unResult action = do

2433 res <- action

warp/test/RunSpec.hs+25

@@ -377,6 +377,31 @@ spec = do

377377 res <- sendGET $ "http://127.0.0.1:" ++ show port

378378 rspBody res `shouldBe` "HelloHelloHelloHello"

379379

380+ describe "head requests" $ do

381+ let fp = "test/head-response"

382+ let app req f =

383+ f $ case pathInfo req of

384+ ["builder"] -> responseBuilder status200 [] $ error "should never be evaluated"

385+ ["streaming"] -> responseStream status200 [] $ \write _ ->

386+ write $ error "should never be evaluated"

387+ ["file"] -> responseFile status200 [] fp Nothing

388+ _ -> error "invalid path"

389+ it "builder" $ withApp defaultSettings app $ \port -> do

390+ res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]

391+ rspBody res `shouldBe` ""

392+ it "streaming" $ withApp defaultSettings app $ \port -> do

393+ res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]

394+ rspBody res `shouldBe` ""

395+ it "file, no range" $ withApp defaultSettings app $ \port -> do

396+ bs <- S.readFile fp

397+ res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]

398+ getHeaderValue HdrContentLength res `shouldBe` Nothing

399+ it "file, with range" $ withApp defaultSettings app $ \port -> do

400+ res <- sendHEADwH

401+ (concat ["http://127.0.0.1:", show port, "/file"])

402+ [mkHeader HdrRange "bytes=0-1"]

403+ getHeaderValue HdrContentLength res `shouldBe` Nothing

404+

380405consumeBody :: IO ByteString -> IO [ByteString]

381406consumeBody body =

382407 loop id

warp/test/head-responsenew file+1

@@ -0,0 +1 @@

1+This is the body

warp/warp.cabal+1

@@ -18,6 +18,7 @@ description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.

1818extra-source-files: attic/hex

1919 ChangeLog.md

2020 README.md

21+ test/head-response

2122

2223Flag network-bytestring

2324 Default: False