88e069c · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

fix etag parameter handling

88e069cGreg Weber15 years ago

Network/Wai/Application/Static.hs+60−31

compare with master

unifiedsplit

@@ -85,15 +85,13 @@ import Data.Function (on)

85import Data.Ord (comparing)

86import qualified Data.ByteString.Base64 as B64

87import Data.Either (rights)

88+import Data.Maybe (isJust, fromJust)

89−#ifdef PRINT

90+{-

90import Debug.Trace

91import Debug.Trace

91debug :: (Show a) => a -> a

92debug :: (Show a) => a -> a

92debug a = trace ("DEBUG: " ++ show a) a

93debug a = trace ("DEBUG: " ++ show a) a

93−#else

94+-}

94−debug :: a -> a

95−debug = id

96−#endif

98-- | A list of all possible extensions, starting from the largest.

96-- | A list of all possible extensions, starting from the largest.

99takeExtensions :: FilePath -> [String]

97takeExtensions :: FilePath -> [String]

@@ -189,8 +187,9 @@ mimeTypeByExt mm def =

189defaultMimeTypeByExt :: FilePath -> MimeType

187defaultMimeTypeByExt :: FilePath -> MimeType

190defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType

188defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType

191

189

192−data CheckPieces

190+data CheckPieces =

191+ -- | Just the etag hash or Nothing for no etag hash

193− = Redirect Pieces

192+ Redirect Pieces (Maybe ByteString)

194 | Forbidden

193 | Forbidden

195 | NotFound

194 | NotFound

196 | FileResponse File H.ResponseHeaders

195 | FileResponse File H.ResponseHeaders

@@ -251,7 +250,7 @@ checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function

251checkPieces fileLookup indices pieces req maxAge

250checkPieces fileLookup indices pieces req maxAge

252 | any (unsafe . piecePretty) pieces = return Forbidden

251 | any (unsafe . piecePretty) pieces = return Forbidden

253 | any (T.null . piecePretty) $ safeInit pieces =

252 | any (T.null . piecePretty) $ safeInit pieces =

254− return $ Redirect $ filterButLast (not . T.null . piecePretty) pieces

253+ return $ Redirect (filterButLast (not . T.null . piecePretty) pieces) Nothing

255 | otherwise = do

254 | otherwise = do

256 let (isFile, isFolder) =

255 let (isFile, isFolder) =

257 case () of

256 case () of

@@ -264,16 +263,17 @@ checkPieces fileLookup indices pieces req maxAge

264 case (fl, isFile) of

263 case (fl, isFile) of

265 (Nothing, _) -> return NotFound

264 (Nothing, _) -> return NotFound

266 (Just (Right file), True) -> handleCache file

265 (Just (Right file), True) -> handleCache file

267− (Just Right{}, False) -> return $ Redirect $ init pieces

266+ (Just Right{}, False) -> return $ Redirect (init pieces) Nothing

268 (Just (Left folder@(Folder _ contents)), _) -> do

267 (Just (Left folder@(Folder _ contents)), _) -> do

269 case checkIndices $ map fileName $ rights contents of

268 case checkIndices $ map fileName $ rights contents of

270− Just index -> return $ Redirect $ setLast pieces $ Piece (T.unpack index) index

269+ Just index -> return $ Redirect (setLast pieces $ Piece (T.unpack index) index) Nothing

271 Nothing ->

270 Nothing ->

272 if isFolder

271 if isFolder

273 then return $ DirectoryResponse folder

272 then return $ DirectoryResponse folder

274− else return $ Redirect $ pieces ++ [Piece "" ""]

273+ else return $ Redirect (pieces ++ [Piece "" ""]) Nothing

275 where

274 where

276 headers = W.requestHeaders req

275 headers = W.requestHeaders req

276+ queryString = W.queryString req

277

278 -- HTTP caching has a cache control header that you can set an expire time for a resource.

279 -- Max-Age is easiest because it is a simple number

@@ -285,29 +285,42 @@ checkPieces fileLookup indices pieces req maxAge

285 --

286 -- We should set a cache control and one of ETag or last-modifed whenever possible

287 --

288− -- in a Yesod web application we append an etag parameter to static assets.

288+ -- In a Yesod web application we can append an etag parameter to static assets.

289− -- This should set both a max-age and ETag header

289+ -- This signals that both a max-age and ETag header should be set

290 -- if there is no etag parameter

291 -- * don't set the max-age

292 -- * set ETag or last-modified

293 -- * ETag must be calculated ahead of time.

294 -- * last-modified is just the file mtime.

295− handleCache file =

295+ handleCache file = do

296− case (lookup "if-none-match" headers, fileGetHash file) of

296+ let mGetHash = fileGetHash file

297− -- etag

297+ let etagParam = lookup "etag" queryString

298+

299+ case (etagParam, mGetHash) of

298− (Just lastHash, Just getHash) -> do

300+ (Just mEtag, Just getHash) -> do

299− hash <- getHash

301+ hash <- getHash

300− if hash == lastHash

302+ if isJust mEtag && hash == fromJust mEtag

301− then return NotModified

302− else return $ FileResponse file $ ("ETag", hash):cacheControl

303+ then return $ FileResponse file $ ("ETag", hash):cacheControl

303− _ ->

304+ else return $ Redirect pieces (Just hash)

305+ -- a file used to have an etag parameter, but no longer does

306+ (Just _, Nothing) -> return $ Redirect pieces Nothing

307+

308+ _ ->

309+ case (lookup "if-none-match" headers, mGetHash) of

310+ -- etag

311+ (Just lastHash, Just getHash) -> do

312+ hash <- getHash

313+ if hash == lastHash

314+ then return NotModified

315+ else return $ FileResponse file $ [("ETag", hash)]

316+ _ ->

304− case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of

317+ case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of

305− -- last-modified

318+ -- last-modified

306− (Just lastSent, Just modified) -> do

319+ (Just lastSent, Just modified) -> do

307− if lastSent >= modified

320+ if lastSent >= modified

308− then return NotModified

321+ then return NotModified

309− else respond file

322+ else respond file

310− _ -> respond file

323+ _ -> respond file

311

324

312 respond file = do

325 respond file = do

313 mhash <- maybe (return Nothing) (fmap Just) $ fileGetHash file

326 mhash <- maybe (return Nothing) (fmap Just) $ fileGetHash file

@@ -519,6 +532,18 @@ status304, statusNotModified :: H.Status

519status304 = H.Status 304 "Not Modified"

532status304 = H.Status 304 "Not Modified"

520statusNotModified = status304

533statusNotModified = status304

521

534

535+-- alist helper functions

536+replace :: Eq a => a -> b -> [(a, b)] -> [(a, b)]

537+replace k v [] = [(k,v)]

538+replace k v (x:xs) | fst x == k = (k,v):xs

539+ | otherwise = x:replace k v xs

540+

541+remove :: Eq a => a -> [(a, b)] -> [(a, b)]

542+remove _ [] = []

543+remove k (x:xs) | fst x == k = xs

544+ | otherwise = x:remove k xs

545+

546+

522staticAppPieces :: StaticSettings -> Pieces -> W.Application

547staticAppPieces :: StaticSettings -> Pieces -> W.Application

523staticAppPieces _ _ req

548staticAppPieces _ _ req

524 | W.requestMethod req /= "GET" = return $ W.responseLBS

549 | W.requestMethod req /= "GET" = return $ W.responseLBS

@@ -559,12 +584,16 @@ staticAppPieces ss pieces req = liftIO $ do

559 [ ("Content-Type", mt)

584 [ ("Content-Type", mt)

560 -- TODO: set Content-Length

585 -- TODO: set Content-Length

561 ] lbs

586 ] lbs

587+

562− Redirect pieces' -> do

588+ Redirect pieces' mHash -> do

563 let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map piecePretty pieces')

589 let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map piecePretty pieces')

590+ let qString = case mHash of

591+ Just hash -> replace "etag" (Just hash) (W.queryString req)

592+ Nothing -> remove "etag" (W.queryString req)

564

593

565 return $ W.responseLBS H.status301

594 return $ W.responseLBS H.status301

566 [ ("Content-Type", "text/plain")

595 [ ("Content-Type", "text/plain")

567− , ("Location", loc)

596+ , ("Location", S8.append loc $ H.renderQuery True qString)

568 ] "Redirect"

597 ] "Redirect"

569 Forbidden -> return $ W.responseLBS H.status403

598 Forbidden -> return $ W.responseLBS H.status403

570 [ ("Content-Type", "text/plain")

599 [ ("Content-Type", "text/plain")

tests/runtests.hs+59−41

@@ -1,4 +1,4 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}

2import Network.Wai.Application.Static

4import Test.Hspec.Monadic

@@ -41,11 +41,14 @@ setRawPathInfo r rawPinfo =

41 in r { rawPathInfo = rawPinfo, pathInfo = pInfo }

44+-- debug :: String -> m0 ()

45+debug = liftIO . hPutStrLn stderr

46+

44main :: IO a

47main :: IO a

45main = hspecX $ do

48main = hspecX $ do

46 let must = liftIO . assert

49 let must = liftIO . assert

47− let info = liftIO . hPutStrLn stderr

51+{-

49 describe "Pieces: pathFromPieces" $ do

52 describe "Pieces: pathFromPieces" $ do

50 it "converts to a file path" $

53 it "converts to a file path" $

51 (pathFromPieces "prefix" [Piece "a" "a", Piece "bc" "bc"]) @?= "prefix/a/bc"

54 (pathFromPieces "prefix" [Piece "a" "a", Piece "bc" "bc"]) @?= "prefix/a/bc"

@@ -53,21 +56,13 @@ main = hspecX $ do

53 prop "each piece is in file path" $ \piecesS ->

56 prop "each piece is in file path" $ \piecesS ->

54 let pieces = map (\p -> Piece p "") piecesS

57 let pieces = map (\p -> Piece p "") piecesS

55 in all (\p -> ("/" ++ p) `isInfixOf` (pathFromPieces "root" $ pieces)) piecesS

58 in all (\p -> ("/" ++ p) `isInfixOf` (pathFromPieces "root" $ pieces)) piecesS

59+-}

58− let statApp = flip runSession $ staticApp defaultFileServerSettings {ssFolder = fileSystemLookup "tests"}

62+ let fileServerApp = flip runSession $ staticApp defaultFileServerSettings {ssFolder = fileSystemLookup "tests"}

59− describe "staticApp" $ do

60− it "403 for unsafe paths" $ statApp $

61− flip mapM_ ["..", "."] $ \path ->

62− assertStatus 403 =<<

63− request (setRawPathInfo defRequest path)

64−

65− it "200 for hidden paths" $ statApp $

66− flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->

67− assertStatus 200 =<<

68− request (setRawPathInfo defRequest path)

64+ describe "fileServerApp" $ do

70− it "directory listing for index" $ statApp $ do

65+ it "directory listing for index" $ fileServerApp $ do

71 resp <- request (setRawPathInfo defRequest "a/")

66 resp <- request (setRawPathInfo defRequest "a/")

72 assertStatus 200 resp

67 assertStatus 200 resp

73 let body = simpleBody resp

68 let body = simpleBody resp

@@ -76,11 +71,28 @@ main = hspecX $ do

76 must $ body `contains` "<img src=\"../.hidden/folder.png\" alt=\"Folder\" />"

71 must $ body `contains` "<img src=\"../.hidden/folder.png\" alt=\"Folder\" />"

77 must $ body `contains` "<a href=\"b\">b</a>"

72 must $ body `contains` "<a href=\"b\">b</a>"

74+ let webApp = flip runSession $ staticApp defaultWebAppSettings {ssFolder = fileSystemLookup "tests"}

75+

76+ {-

77+ describe "webApp" $ do

78+ it "403 for unsafe paths" $ webApp $

79+ flip mapM_ ["..", "."] $ \path ->

80+ assertStatus 403 =<<

81+ request (setRawPathInfo defRequest path)

82+

83+ it "200 for hidden paths" $ webApp $

84+ flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->

85+ assertStatus 200 =<<

86+ request (setRawPathInfo defRequest path)

87+

88+-}

89+

90+{-

79− it "404 for non-existant files" $ statApp $

91+ it "404 for non-existant files" $ webApp $

80 assertStatus 404 =<<

92 assertStatus 404 =<<

81 request (setRawPathInfo defRequest "doesNotExist")

93 request (setRawPathInfo defRequest "doesNotExist")

83− it "301 redirect when multiple slashes" $ statApp $ do

95+ it "301 redirect when multiple slashes" $ webApp $ do

84 req <- request (setRawPathInfo defRequest "a//b/c")

96 req <- request (setRawPathInfo defRequest "a//b/c")

85 assertStatus 301 req

97 assertStatus 301 req

86 assertHeader "Location" "../../a/b/c" req

98 assertHeader "Location" "../../a/b/c" req

@@ -93,52 +105,57 @@ main = hspecX $ do

93 req <- request (setRawPathInfo defRequest path)

105 req <- request (setRawPathInfo defRequest path)

94 assertStatus 301 req

106 assertStatus 301 req

95 assertHeader "Location" "http://www.example.com/a/b/c" req

107 assertHeader "Location" "http://www.example.com/a/b/c" req

108+-}

109

97− describe "when requesting a static asset" $ do

110+ describe "webApp when requesting a static asset" $ do

98− let runtests = setRawPathInfo defRequest "runtests.hs"

111+ let statFile = setRawPathInfo defRequest "a/b"

112+ {-

99− it "200 when no query parameters" $ statApp $ do

113+ it "200 when no query parameters" $ webApp $ do

100− req <- request runtests

114+ req <- request statFile

101 assertStatus 200 req

115 assertStatus 200 req

102 assertNoHeader "Cache-Control" req

116 assertNoHeader "Cache-Control" req

103

117

104− it "200 when invalid if-modified-since header" $ statApp $ do

118+ it "200 when no cache headers and bad cache query string" $ webApp $ do

105− req <- request runtests {

119+ req <- request statFile { queryString = [("etag", Just "cached")] }

106− requestHeaders = [("If-Modified-Since", "")]

107− }

108− assertStatus 200 req

120+ assertStatus 301 req

121+ assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req

109 assertNoHeader "Cache-Control" req

122 assertNoHeader "Cache-Control" req

110

123

111− it "200 when no cache headers and no cache query string" $ statApp $ do

124+ it "200 when no cache headers and empty cache query string" $ webApp $ do

112− req <- request runtests { rawQueryString ="?foo" }

125+ req <- request statFile { queryString = [("etag", Nothing)] }

113− assertStatus 200 req

126+ assertStatus 301 req

127+ assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req

114 assertNoHeader "Cache-Control" req

128 assertNoHeader "Cache-Control" req

115

129

116− it "200 when no cache headers and bad cache query string" $ statApp $ do

130+ it "Cache-Control set when etag parameter is correct" $ webApp $ do

117− req <- request runtests { rawQueryString ="?etag=cached" }

131+ req <- request statFile { queryString = [("etag", Just "1B2M2Y8AsgTpgAmY7PhCfg==")] }

118 assertStatus 200 req

132 assertStatus 200 req

119− assertNoHeader "Cache-Control" req

133+ assertHeader "Cache-Control" "max-age=31536000" req

134+ -}

120

135

121− it "200 when no cache headers and bad cache query string" $ statApp $ do

136+ it "200 when invalid if-modified-since header" $ webApp $ do

122− req <- request runtests { rawQueryString ="?etag=" }

137+ req <- request statFile {

138+ requestHeaders = [("If-Modified-Since", "123")]

139+ }

123 assertStatus 200 req

140 assertStatus 200 req

124− assertHeader "Cache-Control" "max-age=31536000" req

141+ assertNoHeader "Cache-Control" req

125

142

126− it "200 when empty If-Unmodified-Since" $ statApp $ do

143+ it "200 when empty If-Unmodified-Since" $ webApp $ do

127− req <- request runtests { rawQueryString ="?cached",

144+ req <- request statFile {

128 requestHeaders = [("If-Unmodified-Since", "")]

145 requestHeaders = [("If-Unmodified-Since", "")]

129 }

146 }

130− info "WTF??***"

131 assertStatus 200 req

147 assertStatus 200 req

132− assertHeader "Cache-Control" "max-age=31536000" req

148+ assertNoHeader "Cache-Control" req

133

149

134− it "304 when cache header and query parameter sent" $ statApp $ do

150+ it "304 when if-modified-since matches" $ webApp $ do

135− req <- request runtests { rawQueryString ="?cached",

151+ req <- request statFile {

136 requestHeaders = [("If-Modified-Since", "")]

152 requestHeaders = [("If-Modified-Since", "")]

137 }

153 }

138 assertStatus 304 req

154 assertStatus 304 req

139 assertNoHeader "Cache-Control" req

155 assertNoHeader "Cache-Control" req

156+{-

140

157

141− let pubApp = flip runSession $ staticApp defaultWebAppSettings {ssFolder = fileSystemLookup "tests"}

158+ let pubApp = flip runSession $ staticApp defaultFileServerSettings {ssFolder = fileSystemLookup "tests"}

142 describe "staticApp when requesting a public asset - etags" $ do

159 describe "staticApp when requesting a public asset - etags" $ do

143 it "200 when no etag parameters" $ pubApp $ do

160 it "200 when no etag parameters" $ pubApp $ do

144 req <- request (setRawPathInfo defRequest "runtests.hs")

161 req <- request (setRawPathInfo defRequest "runtests.hs")

@@ -149,3 +166,4 @@ main = hspecX $ do

149 req <- request (setRawPathInfo defRequest "runtests.hs") { requestHeaders = [("If-None-Match", "hash")] }

166 req <- request (setRawPathInfo defRequest "runtests.hs") { requestHeaders = [("If-None-Match", "hash")] }

150 assertStatus 304 req

167 assertStatus 304 req

151 assertNoHeader "Etag" req

168 assertNoHeader "Etag" req

169+ -}