git.iko.soy/typeable/wai
on master help sign in
Merge pull request #8 from gregwebs/last-modified
7ec3980Michael Snoyman
Network/Wai/Application/Static.hs+47−44
compare with master
unifiedsplit
@@ -77,6 +77,7 @@ import Data.FileEmbed (embedFile)
77
77
78import qualified Data.Text as T
78import qualified Data.Text as T
79import qualified Data.Text.Encoding as TE
79import qualified Data.Text.Encoding as TE
80+import qualified Data.Text.Encoding.Error as TEE
80
81
81import Control.Arrow ((&&&), second)
82import Control.Arrow ((&&&), second)
82import Data.List (groupBy, sortBy, find)
83import Data.List (groupBy, sortBy, find)
@@ -85,11 +86,12 @@ import Data.Ord (comparing)
85import qualified Data.ByteString.Base64 as B64
86import qualified Data.ByteString.Base64 as B64
86import Data.Either (rights)
87import Data.Either (rights)
87import Data.Maybe (isJust, fromJust)
88import Data.Maybe (isJust, fromJust)
89+import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)
88
90
89−{-
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
94+{-
93-}
95-}
94
96
95-- | A list of all possible extensions, starting from the largest.
97-- | A list of all possible extensions, starting from the largest.
@@ -245,8 +247,9 @@ checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
245 -> Pieces -- ^ parsed request
247 -> Pieces -- ^ parsed request
246 -> W.Request
248 -> W.Request
247 -> MaxAge
249 -> MaxAge
250+ -> Bool
248 -> IO CheckPieces
251 -> IO CheckPieces
249−checkPieces fileLookup indices pieces req maxAge
252+checkPieces fileLookup indices pieces req maxAge useHash
250 | any (unsafe . piecePretty) pieces = return Forbidden
253 | any (unsafe . piecePretty) pieces = return Forbidden
251 | any (T.null . piecePretty) $ safeInit pieces =
254 | any (T.null . piecePretty) $ safeInit pieces =
252 return $ Redirect (filterButLast (not . T.null . piecePretty) pieces) Nothing
255 return $ Redirect (filterButLast (not . T.null . piecePretty) pieces) Nothing
@@ -291,42 +294,45 @@ checkPieces fileLookup indices pieces req maxAge
291 -- * set ETag or last-modified
294 -- * set ETag or last-modified
292 -- * ETag must be calculated ahead of time.
295 -- * ETag must be calculated ahead of time.
293 -- * last-modified is just the file mtime.
296 -- * last-modified is just the file mtime.
294− handleCache file = do
297+ handleCache file =
298+ if not useHash then lastModifiedCache file
299+ else do
295− let mGetHash = fileGetHash file
300+ let mGetHash = fileGetHash file
296− let etagParam = lookup "etag" queryString
301+ let etagParam = lookup "etag" queryString
297−
302+
298− case (etagParam, mGetHash) of
303+ case (etagParam, mGetHash) of
299− (Just mEtag, Just getHash) -> do
304+ (Just mEtag, Just getHash) -> do
300− hash <- getHash
305+ hash <- getHash
301− if isJust mEtag && hash == fromJust mEtag
306+ if isJust mEtag && hash == fromJust mEtag
302− then return $ FileResponse file $ ("ETag", hash):cacheControl
307+ then return $ FileResponse file $ ("ETag", hash):cacheControl
303− else return $ Redirect pieces (Just hash)
308+ else return $ Redirect pieces (Just hash)
304− -- a file used to have an etag parameter, but no longer does
309+ -- a file used to have an etag parameter, but no longer does
305− (Just _, Nothing) -> return $ Redirect pieces Nothing
310+ (Just _, Nothing) -> return $ Redirect pieces Nothing
306−
311+
307− _ ->
312+ _ ->
308− case (lookup "if-none-match" headers, mGetHash) of
313+ case (lookup "if-none-match" headers, mGetHash) of
309− -- etag
314+ -- etag
310− (Just lastHash, Just getHash) -> do
315+ (mLastHash, Just getHash) -> do
311− hash <- getHash
316+ hash <- getHash
312− if hash == lastHash
317+ case mLastHash of
313− then return NotModified
318+ Just lastHash ->
314− else return $ FileResponse file $ [("ETag", hash)]
319+ if hash == lastHash
315− _ ->
316− case (lookup "if-modified-since" headers >>= parseModifiedDate, fileGetModified file) of
317− -- last-modified
318− (Just lastSent, Just modified) -> do
319− if lastSent >= modified
320 then return NotModified
320 then return NotModified
321− else respond file
321+ else return $ FileResponse file $ [("ETag", hash)]
322− _ -> respond file
322+ Nothing -> return $ FileResponse file $ [("ETag", hash)]
323−
323+ (_, Nothing) -> lastModifiedCache file
324− respond file = do
324+
325− mhash <- maybe (return Nothing) (fmap Just) $ fileGetHash file
325+ lastModifiedCache file =
326− return $ FileResponse file $
326+ case (lookup "if-modified-since" headers >>= parseHTTPDate, fileGetModified file) of
327+ (mLastSent, Just modified) -> do
328+ let mdate = epochTimeToHTTPDate modified in
327− case mhash of
329+ case mLastSent of
328− Just h -> [("ETag", h)]
330+ Just lastSent ->
329− Nothing -> []
331+ if lastSent == mdate
332+ then return NotModified
333+ else return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)]
334+ Nothing -> return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)]
335+ _ -> return $ FileResponse file []
330
336
331 setLast :: Pieces -> Piece -> Pieces
337 setLast :: Pieces -> Piece -> Pieces
332 setLast [] x = [x]
338 setLast [] x = [x]
@@ -366,12 +372,6 @@ data File = File
366 , fileGetModified :: Maybe EpochTime
372 , fileGetModified :: Maybe EpochTime
367 }
373 }
368
374
369−parseModifiedDate :: ByteString -> Maybe EpochTime
370−parseModifiedDate =
371− fmap (fromInteger . round . utcTimeToPOSIXSeconds) . parseTime defaultTimeLocale format . S8.unpack
372− where
373− format = "%a, %d %b %Y %X %Z"
374−
375data StaticSettings = StaticSettings
375data StaticSettings = StaticSettings
376 { ssFolder :: Pieces -> IO FileLookup
376 { ssFolder :: Pieces -> IO FileLookup
377 , ssMkRedirect :: Pieces -> ByteString -> ByteString
377 , ssMkRedirect :: Pieces -> ByteString -> ByteString
@@ -379,6 +379,7 @@ data StaticSettings = StaticSettings
379 , ssListing :: Maybe Listing
379 , ssListing :: Maybe Listing
380 , ssIndices :: [T.Text] -- index.html
380 , ssIndices :: [T.Text] -- index.html
381 , ssMaxAge :: MaxAge
381 , ssMaxAge :: MaxAge
382+ , ssUseHash :: Bool
382 }
383 }
383
384
384data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever
385data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever
@@ -400,6 +401,7 @@ defaultWebAppSettings = StaticSettings
400 , ssMaxAge = MaxAgeForever
401 , ssMaxAge = MaxAgeForever
401 , ssListing = Nothing
402 , ssListing = Nothing
402 , ssIndices = []
403 , ssIndices = []
404+ , ssUseHash = True
403 }
405 }
404
406
405defaultFileServerSettings :: StaticSettings
407defaultFileServerSettings :: StaticSettings
@@ -410,6 +412,7 @@ defaultFileServerSettings = StaticSettings
410 , ssMaxAge = MaxAgeSeconds $ 60 * 60
412 , ssMaxAge = MaxAgeSeconds $ 60 * 60
411 , ssListing = Just defaultListing
413 , ssListing = Just defaultListing
412 , ssIndices = ["index.html", "index.htm"]
414 , ssIndices = ["index.html", "index.htm"]
415+ , ssUseHash = False
413 }
416 }
414
417
415fileHelper :: FilePath -> T.Text -> IO File
418fileHelper :: FilePath -> T.Text -> IO File
@@ -553,7 +556,7 @@ staticAppPieces ss pieces req = liftIO $ do
553 let indices = ssIndices ss
556 let indices = ssIndices ss
554 case checkSpecialDirListing pieces of
557 case checkSpecialDirListing pieces of
555 Just res -> response res
558 Just res -> response res
556− Nothing -> checkPieces (ssFolder ss) indices pieces req (ssMaxAge ss) >>= response
559+ Nothing -> checkPieces (ssFolder ss) indices pieces req (ssMaxAge ss) (ssUseHash ss) >>= response
557 where
560 where
558 response cp = case cp of
561 response cp = case cp of
559 FileResponse file ch -> do
562 FileResponse file ch -> do
tests/runtests.hs+13−4
@@ -103,6 +103,7 @@ main = hspecX $ do
103 assertStatus 200 req
103 assertStatus 200 req
104 assertNoHeader "Cache-Control" req
104 assertNoHeader "Cache-Control" req
105 assertHeader "ETag" etag req
105 assertHeader "ETag" etag req
106+ assertNoHeader "Last-Modified" req
106
107
107 it "200 when no cache headers and bad cache query string" $ webApp $ do
108 it "200 when no cache headers and bad cache query string" $ webApp $ do
108 flip mapM_ [Just "cached", Nothing] $ \badETag -> do
109 flip mapM_ [Just "cached", Nothing] $ \badETag -> do
@@ -110,24 +111,32 @@ main = hspecX $ do
110 assertStatus 301 req
111 assertStatus 301 req
111 assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req
112 assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req
112 assertNoHeader "Cache-Control" req
113 assertNoHeader "Cache-Control" req
114+ assertNoHeader "Last-Modified" req
113
115
114 it "Cache-Control set when etag parameter is correct" $ webApp $ do
116 it "Cache-Control set when etag parameter is correct" $ webApp $ do
115 req <- request statFile { queryString = [("etag", Just etag)] }
117 req <- request statFile { queryString = [("etag", Just etag)] }
116 assertStatus 200 req
118 assertStatus 200 req
117 assertHeader "Cache-Control" "max-age=31536000" req
119 assertHeader "Cache-Control" "max-age=31536000" req
120+ assertNoHeader "Last-Modified" req
118
121
119 it "200 when invalid in-none-match sent" $ webApp $
122 it "200 when invalid in-none-match sent" $ webApp $
120 flip mapM_ ["cached", ""] $ \badETag -> do
123 flip mapM_ ["cached", ""] $ \badETag -> do
121 req <- request statFile { requestHeaders = [("If-None-Match", badETag)] }
124 req <- request statFile { requestHeaders = [("If-None-Match", badETag)] }
122 assertStatus 200 req
125 assertStatus 200 req
123 assertHeader "ETag" etag req
126 assertHeader "ETag" etag req
127+ assertNoHeader "Last-Modified" req
124
128
125 it "304 when valid if-none-match sent" $ webApp $ do
129 it "304 when valid if-none-match sent" $ webApp $ do
126 req <- request statFile { requestHeaders = [("If-None-Match", etag)] }
130 req <- request statFile { requestHeaders = [("If-None-Match", etag)] }
127 assertStatus 304 req
131 assertStatus 304 req
128 assertNoHeader "Etag" req
132 assertNoHeader "Etag" req
133+ assertNoHeader "Last-Modified" req
129
134
130 describe "fileServerApp" $ do
135 describe "fileServerApp" $ do
136+ let fileDate = do
137+ stat <- liftIO $ getFileStatus $ "tests/" ++ file
138+ return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat
139+
131 it "directory listing for index" $ fileServerApp $ do
140 it "directory listing for index" $ fileServerApp $ do
132 resp <- request (setRawPathInfo defRequest "a/")
141 resp <- request (setRawPathInfo defRequest "a/")
133 assertStatus 200 resp
142 assertStatus 200 resp
@@ -144,13 +153,13 @@ main = hspecX $ do
144 }
153 }
145 assertStatus 200 req
154 assertStatus 200 req
146 assertNoHeader "Cache-Control" req
155 assertNoHeader "Cache-Control" req
156+ fdate <- fileDate
157+ assertHeader "Last-Modified" fdate req
147
158
148 it "304 when if-modified-since matches" $ fileServerApp $ do
159 it "304 when if-modified-since matches" $ fileServerApp $ do
149− -- formatTime defaultTimeLocale format $
160+ fdate <- fileDate
150− -- let format = "%a, %d %b %Y %X %Z"
151− stat <- liftIO $ getFileStatus $ "tests/" ++ file
152 req <- request statFile {
161 req <- request statFile {
153− requestHeaders = [("If-Modified-Since", formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat)]
162+ requestHeaders = [("If-Modified-Since", fdate)]
154 }
163 }
155 assertStatus 304 req
164 assertStatus 304 req
156 assertNoHeader "Cache-Control" req
165 assertNoHeader "Cache-Control" req