git.iko.soy/typeable/wai
on master help sign in
Various caching changes
b66adeaMichael Snoyman
Network/Wai/Application/Static.hs+88−61
compare with master
unifiedsplit
@@ -30,8 +30,6 @@ module Network.Wai.Application.Static
30 -- ** Settings
30 -- ** Settings
31 , StaticSettings (..)
31 , StaticSettings (..)
32 , defaultStaticSettings
32 , defaultStaticSettings
33− , defaultPublicSettings
34− , CacheSettings (..)
35 -- should be moved to common helper
33 -- should be moved to common helper
36 , unfixPathName
34 , unfixPathName
37 -- new stuff to be sorted
35 -- new stuff to be sorted
@@ -41,6 +39,7 @@ module Network.Wai.Application.Static
41 , File (..)
39 , File (..)
42 , toEmbedded
40 , toEmbedded
43 , StaticDirListing (..)
41 , StaticDirListing (..)
42+ , MaxAge (..)
44 ) where
43 ) where
45
44
46import qualified Network.Wai as W
45import qualified Network.Wai as W
@@ -56,6 +55,7 @@ import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
56import System.Posix.Types (FileOffset, EpochTime)
55import System.Posix.Types (FileOffset, EpochTime)
57import Control.Monad.IO.Class (liftIO)
56import Control.Monad.IO.Class (liftIO)
58import Data.Maybe (catMaybes, isNothing, isJust)
57import Data.Maybe (catMaybes, isNothing, isJust)
58+import qualified Crypto.Hash.MD5 as MD5
59
59
60import Text.Blaze ((!))
60import Text.Blaze ((!))
61import qualified Text.Blaze.Html5 as H
61import qualified Text.Blaze.Html5 as H
@@ -79,6 +79,7 @@ import Control.Arrow ((&&&), second)
79import Data.List (groupBy, sortBy)
79import Data.List (groupBy, sortBy)
80import Data.Function (on)
80import Data.Function (on)
81import Data.Ord (comparing)
81import Data.Ord (comparing)
82+import qualified Data.ByteString.Base64 as B64
82
83
83#ifdef PRINT
84#ifdef PRINT
84import Debug.Trace
85import Debug.Trace
@@ -188,7 +189,7 @@ data CheckPieces
188 = Redirect Pieces
189 = Redirect Pieces
189 | Forbidden
190 | Forbidden
190 | NotFound
191 | NotFound
191− | FileResponse File
192+ | FileResponse File H.ResponseHeaders
192 | NotModified
193 | NotModified
193 | DirectoryResponse Folder
194 | DirectoryResponse Folder
194 -- TODO: add file size
195 -- TODO: add file size
@@ -233,14 +234,14 @@ pathFromPieces prefix pieces =
233checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
234checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
234 -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
235 -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
235 -> Pieces -- ^ parsed request
236 -> Pieces -- ^ parsed request
236− -> CacheSettings
237 -> W.Request
237 -> W.Request
238+ -> StaticSettings
238 -> IO CheckPieces
239 -> IO CheckPieces
239checkPieces _ _ [Piece _ ".hidden", Piece _ "folder.png"] _ _ =
240checkPieces _ _ [Piece _ ".hidden", Piece _ "folder.png"] _ _ =
240 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
241 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
241checkPieces _ _ [Piece _ ".hidden", Piece _ "haskell.png"] _ _ =
242checkPieces _ _ [Piece _ ".hidden", Piece _ "haskell.png"] _ _ =
242 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
243 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
243−checkPieces fileLookup indices pieces cache req
244+checkPieces fileLookup indices pieces req ss
244 | any (unsafe . piecePretty) pieces = return Forbidden
245 | any (unsafe . piecePretty) pieces = return Forbidden
245 | any (T.null . piecePretty) $ safeInit pieces =
246 | any (T.null . piecePretty) $ safeInit pieces =
246 return $ Redirect $ filterButLast (not . T.null . piecePretty) pieces
247 return $ Redirect $ filterButLast (not . T.null . piecePretty) pieces
@@ -255,7 +256,7 @@ checkPieces fileLookup indices pieces cache req
255 fl <- fileLookup pieces
256 fl <- fileLookup pieces
256 case (fl, isFile) of
257 case (fl, isFile) of
257 (FLDoesNotExist, _) -> return NotFound
258 (FLDoesNotExist, _) -> return NotFound
258− (FLFile file, True) -> handleCache file cache
259+ (FLFile file, True) -> handleCache file
259 (FLFile{}, False) -> return $ Redirect $ init pieces
260 (FLFile{}, False) -> return $ Redirect $ init pieces
260 (FLFolder folder@(Folder contents), _) -> do
261 (FLFolder folder@(Folder contents), _) -> do
261 case checkIndices $ map feName $ filter feIsFile contents of
262 case checkIndices $ map feName $ filter feIsFile contents of
@@ -265,20 +266,40 @@ checkPieces fileLookup indices pieces cache req
265 then return $ DirectoryResponse folder
266 then return $ DirectoryResponse folder
266 else return $ Redirect $ pieces ++ [Piece "" ""]
267 else return $ Redirect $ pieces ++ [Piece "" ""]
267 where
268 where
268− handleCache file NoCache = trace "NoCache" $ return (FileResponse file)
269+ headers = W.requestHeaders req
269− handleCache file (ETag ioLookup) = do
270+ handleCache file =
270− -- No support for If-Match
271+ case (lookup "if-none-match" headers, fileGetHash file) of
271− let mlastEtag = lookup "If-None-Match" (W.requestHeaders req)
272+ (Just lastHash, Just getHash) -> do
272− metag <- ioLookup file
273+ hash <- getHash
273− case debug (metag, mlastEtag) of
274+ if hash == lastHash
274− (Just hash, Just lastHash) | hash == lastHash -> return NotModified
275+ then return NotModified
275− _ -> trace "ETAG: no cache match" (return $ FileResponse file)
276+ else return $ FileResponse file $ cc [("ETag", hash)]
276− handleCache file (Forever isStaticFile) = do
277+ _ ->
277− if isStaticFile file (S8.drop 1 $ W.rawQueryString req) &&
278+ case (lookup "if-modified-since" headers >>= parseDate, fileGetModified file) of
278− (isJust $ lookup "If-Modified-Since" (W.requestHeaders req)) &&
279+ (Just lastSent, Just getMod) -> do
279− (isNothing $ lookup "If-Unmodified-Since" (W.requestHeaders req))
280+ modified <- getMod
280− then return NotModified
281+ if lastSent >= modified
281− else trace "Static: no cache match" (return $ FileResponse file)
282+ then return NotModified
283+ else respond file
284+ _ -> respond file
285+
286+ respond file = do
287+ mhash <- maybe (return Nothing) (fmap Just) $ fileGetHash file
288+ let hash =
289+ case mhash of
290+ Just h -> (:) ("ETag", h)
291+ Nothing -> id
292+ return $ FileResponse file $ hash $ cc []
293+
294+ ccInt =
295+ case ssMaxAge ss of
296+ NoMaxAge -> Nothing
297+ MaxAgeSeconds i -> Just i
298+ MaxAgeForever -> Just oneYear
299+ cc =
300+ case ccInt of
301+ Nothing -> id
302+ Just i -> (:) ("Cache-Control", S8.append "max-age" $ S8.pack $ show i)
282
303
283 setLast [] x = [x]
304 setLast [] x = [x]
284 setLast [Piece "" ""] x = [x]
305 setLast [Piece "" ""] x = [x]
@@ -303,17 +324,6 @@ data StaticDirListing = StaticDirListing {
303defaultDirListing :: StaticDirListing
324defaultDirListing :: StaticDirListing
304defaultDirListing = StaticDirListing (Just defaultListing) []
325defaultDirListing = StaticDirListing (Just defaultListing) []
305
326
306−-- IO is for development mode
307−
308−-- FIXME: Greg: Is the idea with ETag that an implementation could cache the
309−-- hashes at compile time and then not need to recompute them? It might make
310−-- more sense to include that as part of the File datatype itself. If we do
311−-- something like that, would it be possible to get rid of CacheSettings
312−-- altogether?
313−
314−type CheckHashParam = (File -> S8.ByteString -> Bool) -- FIXME Greg: Can you explain the purposes of the parameters here?
315−data CacheSettings = NoCache | Forever CheckHashParam | ETag (File -> IO (Maybe S8.ByteString))
316−
317oneYear :: Int
327oneYear :: Int
318oneYear = 60 * 60 * 24 * 365
328oneYear = 60 * 60 * 24 * 365
319
329
@@ -331,16 +341,23 @@ data File = File
331 { fileGetSize :: IO Int
341 { fileGetSize :: IO Int
332 , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
342 , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
333 , fileName :: T.Text
343 , fileName :: T.Text
344+ , fileGetHash :: Maybe (IO ByteString)
345+ , fileGetModified :: Maybe (IO EpochTime)
334 }
346 }
335
347
348+parseDate :: ByteString -> Maybe EpochTime
349+parseDate = error "parseDate"
350+
336data StaticSettings = StaticSettings
351data StaticSettings = StaticSettings
337 { ssFolder :: Pieces -> IO FileLookup
352 { ssFolder :: Pieces -> IO FileLookup
338− , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString
353+ , ssMkRedirect :: Pieces -> ByteString -> ByteString
339 , ssGetMimeType :: File -> IO MimeType
354 , ssGetMimeType :: File -> IO MimeType
340 , ssDirListing :: StaticDirListing
355 , ssDirListing :: StaticDirListing
341− , ssCacheSettings :: CacheSettings
356+ , ssMaxAge :: MaxAge
342 }
357 }
343
358
359+data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever
360+
344defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString
361defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString
345defaultMkRedirect pieces newPath
362defaultMkRedirect pieces newPath
346 | S8.null newPath || S8.null relDir ||
363 | S8.null newPath || S8.null relDir ||
@@ -350,20 +367,14 @@ defaultMkRedirect pieces newPath
350 where
367 where
351 relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)
368 relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)
352
369
353−defaultStaticSettings :: CacheSettings -> StaticSettings
370+defaultStaticSettings :: StaticSettings
354−defaultStaticSettings isStaticFile = StaticSettings { ssFolder = fileSystemLookup "static"
371+defaultStaticSettings = StaticSettings
372+ { ssFolder = fileSystemLookup "static"
355− , ssMkRedirect = defaultMkRedirect
373+ , ssMkRedirect = defaultMkRedirect
356− , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
374+ , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
357− , ssDirListing = defaultDirListing
375+ , ssDirListing = defaultDirListing
358− , ssCacheSettings = isStaticFile
376+ , ssMaxAge = MaxAgeSeconds $ 60 * 60
359−}
360−defaultPublicSettings :: CacheSettings -> StaticSettings
361−defaultPublicSettings etags = StaticSettings { ssFolder = fileSystemLookup "public"
362− , ssMkRedirect = defaultMkRedirect
363− , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
364− , ssDirListing = StaticDirListing Nothing []
365− , ssCacheSettings = etags
366−}
377+ }
367
378
368fileSystemLookup :: FilePath -> Pieces -> IO FileLookup
379fileSystemLookup :: FilePath -> Pieces -> IO FileLookup
369fileSystemLookup prefix pieces = do
380fileSystemLookup prefix pieces = do
@@ -375,6 +386,12 @@ fileSystemLookup prefix pieces = do
375 { fileGetSize = fmap (fromIntegral . fileSize) $ getFileStatus fp
386 { fileGetSize = fmap (fromIntegral . fileSize) $ getFileStatus fp
376 , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
387 , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
377 , fileName = piecePretty $ last pieces
388 , fileName = piecePretty $ last pieces
389+ , fileGetHash = Just $ do
390+ -- FIXME replace lazy IO with enumerators
391+ -- FIXME let's use a dictionary to cache these values?
392+ l <- L.readFile fp
393+ return $ runHashL l
394+ , fileGetModified = Just $ fmap modificationTime $ getFileStatus fp
378 }
395 }
379 else do
396 else do
380 de <- doesDirectoryExist fp
397 de <- doesDirectoryExist fp
@@ -400,9 +417,8 @@ embeddedLookup :: Embedded -> Pieces -> IO FileLookup
400embeddedLookup root pieces =
417embeddedLookup root pieces =
401 return $ elookup (map piecePretty pieces) root
418 return $ elookup (map piecePretty pieces) root
402 where
419 where
403− modified = 0 -- FIXME
404 elookup :: [T.Text] -> Embedded -> FileLookup
420 elookup :: [T.Text] -> Embedded -> FileLookup
405− elookup [] x = FLFolder $ Folder $ map (toEntry modified) $ Map.toList x
421+ elookup [] x = FLFolder $ Folder $ map toEntry $ Map.toList x
406 elookup [""] x = elookup [] x
422 elookup [""] x = elookup [] x
407 elookup (p:ps) x =
423 elookup (p:ps) x =
408 case Map.lookup p x of
424 case Map.lookup p x of
@@ -413,8 +429,8 @@ embeddedLookup root pieces =
413 _ -> FLDoesNotExist
429 _ -> FLDoesNotExist
414 Just (EEFolder y) -> elookup ps y
430 Just (EEFolder y) -> elookup ps y
415
431
416−toEntry :: EpochTime -> (T.Text, EmbeddedEntry) -> FolderEntry
432+toEntry :: (T.Text, EmbeddedEntry) -> FolderEntry
417−toEntry modified (name, ee) = FolderEntry
433+toEntry (name, ee) = FolderEntry
418 { feName = name
434 { feName = name
419 , feIsFile =
435 , feIsFile =
420 case ee of
436 case ee of
@@ -424,7 +440,7 @@ toEntry modified (name, ee) = FolderEntry
424 case ee of
440 case ee of
425 EEFile bs -> FileMetaData
441 EEFile bs -> FileMetaData
426 { mdName = name
442 { mdName = name
427− , mdModified = modified
443+ , mdModified = Nothing
428 , mdSize = fromIntegral $ S8.length bs
444 , mdSize = fromIntegral $ S8.length bs
429 }
445 }
430 EEFolder _ -> FolderMetaData
446 EEFolder _ -> FolderMetaData
@@ -460,8 +476,16 @@ bsToFile name bs = File
460 { fileGetSize = return $ S8.length bs
476 { fileGetSize = return $ S8.length bs
461 , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
477 , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
462 , fileName = name
478 , fileName = name
479+ , fileGetHash = Just $ return $ runHash bs
480+ , fileGetModified = Nothing
463 }
481 }
464
482
483+runHash :: S8.ByteString -> S8.ByteString
484+runHash = B64.encode . MD5.hash
485+
486+runHashL :: L.ByteString -> ByteString
487+runHashL = B64.encode . MD5.hashlazy
488+
465staticApp :: StaticSettings -> W.Application
489staticApp :: StaticSettings -> W.Application
466staticApp set req =
490staticApp set req =
467 staticAppPieces set (map toPiece $ W.pathInfo req) req
491 staticAppPieces set (map toPiece $ W.pathInfo req) req
@@ -481,16 +505,14 @@ staticAppPieces _ _ req
481 H.status405
505 H.status405
482 [("Content-Type", "text/plain")]
506 [("Content-Type", "text/plain")]
483 "Only GET is supported"
507 "Only GET is supported"
484−staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
508+staticAppPieces ss pieces req = liftIO $ do
485− let cache = ssCacheSettings ss
486 let indices = case ssDirListing ss of
509 let indices = case ssDirListing ss of
487 StaticDirListing _ is -> is
510 StaticDirListing _ is -> is
488− cp <- checkPieces (ssFolder ss) indices pieces cache req
511+ cp <- checkPieces (ssFolder ss) indices pieces req ss
489 case cp of
512 case cp of
490− FileResponse file -> do
513+ FileResponse file ch -> do
491 mimetype <- ssGetMimeType ss file
514 mimetype <- ssGetMimeType ss file
492 filesize <- fileGetSize file
515 filesize <- fileGetSize file
493− ch <- setCacheHeaders cache file
494 let headers = ("Content-Type", mimetype)
516 let headers = ("Content-Type", mimetype)
495 : ("Content-Length", S8.pack $ show filesize)
517 : ("Content-Length", S8.pack $ show filesize)
496 : ch
518 : ch
@@ -537,6 +559,7 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
537 [ ("Content-Type", "text/plain")
559 [ ("Content-Type", "text/plain")
538 ] "File not found"
560 ] "File not found"
539 where
561 where
562+ {-
540 -- expires header: formatTime "%a, %d-%b-%Y %X GMT"
563 -- expires header: formatTime "%a, %d-%b-%Y %X GMT"
541 setCacheHeaders :: CacheSettings -> File -> IO H.ResponseHeaders
564 setCacheHeaders :: CacheSettings -> File -> IO H.ResponseHeaders
542 setCacheHeaders (Forever isStaticFile) fp = return $
565 setCacheHeaders (Forever isStaticFile) fp = return $
@@ -549,6 +572,7 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
549 return $ case etag of
572 return $ case etag of
550 Just hash -> [("ETag", hash)]
573 Just hash -> [("ETag", hash)]
551 Nothing -> []
574 Nothing -> []
575+ -}
552
576
553{-
577{-
554The problem is that the System.Directory functions are a lie: they
578The problem is that the System.Directory functions are a lie: they
@@ -609,7 +633,7 @@ defaultListing pieces (Folder contents) = do
609 haskellSrc = image "haskell"
633 haskellSrc = image "haskell"
610 showName "" = "root"
634 showName "" = "root"
611 showName x = x
635 showName x = x
612− showFolder [] = H.string "error: Unexpected showFolder []"
636+ showFolder [] = H.string "/"
613 showFolder [x] = H.string $ showName x
637 showFolder [x] = H.string $ showName x
614 showFolder (x:xs) = do
638 showFolder (x:xs) = do
615 let href = concat $ replicate (length xs) "../"
639 let href = concat $ replicate (length xs) "../"
@@ -651,7 +675,10 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
651 H.td (H.a ! A.href (H.stringValue $ T.unpack (mdName md) ++ if mdIsFile md then "" else "/") $ H.string $ T.unpack (mdName md))
675 H.td (H.a ! A.href (H.stringValue $ T.unpack (mdName md) ++ if mdIsFile md then "" else "/") $ H.string $ T.unpack (mdName md))
652 H.td ! A.class_ (H.stringValue "date") $ H.string $
676 H.td ! A.class_ (H.stringValue "date") $ H.string $
653 if mdIsFile md
677 if mdIsFile md
678+ then
679+ case mdModified md of
680+ Nothing -> ""
654− then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" $ mdModified md
681+ Just t -> formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
655 else ""
682 else ""
656 H.td ! A.class_ (H.stringValue "size") $ H.string $
683 H.td ! A.class_ (H.stringValue "size") $ H.string $
657 if mdIsFile md
684 if mdIsFile md
@@ -675,7 +702,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
675data MetaData =
702data MetaData =
676 FileMetaData
703 FileMetaData
677 { mdName :: T.Text
704 { mdName :: T.Text
678− , mdModified :: EpochTime
705+ , mdModified :: Maybe EpochTime
679 , mdSize :: FileOffset
706 , mdSize :: FileOffset
680 }
707 }
681 | FolderMetaData
708 | FolderMetaData
@@ -701,7 +728,7 @@ getMetaData localPath fp = do
701 fs <- getFileStatus fp'
728 fs <- getFileStatus fp'
702 let modTime = modificationTime fs
729 let modTime = modificationTime fs
703 let count = fileSize fs
730 let count = fileSize fs
704− return $ Just $ FileMetaData fpPretty modTime count
731+ return $ Just $ FileMetaData fpPretty (Just modTime) count
705 else do
732 else do
706 de <- doesDirectoryExist fp'
733 de <- doesDirectoryExist fp'
707 return $ if de then Just (FolderMetaData fpPretty) else Nothing
734 return $ if de then Just (FolderMetaData fpPretty) else Nothing
sample.hs+1−1
@@ -7,5 +7,5 @@ main = run 3000 $ staticApp StaticSettings
7 , ssMkRedirect = defaultMkRedirect
7 , ssMkRedirect = defaultMkRedirect
8 , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
8 , ssGetMimeType = return . defaultMimeTypeByExt . T.unpack . fileName
9 , ssDirListing = defaultDirListing
9 , ssDirListing = defaultDirListing
10− , ssCacheSettings = NoCache
10+ , ssMaxAge = MaxAgeForever
11 }
11 }
wai-app-static.cabal+2
@@ -32,6 +32,8 @@ library
32 , file-embed >= 0.0.3.1 && < 0.1
32 , file-embed >= 0.0.3.1 && < 0.1
33 , text >= 0.5 && < 1.0
33 , text >= 0.5 && < 1.0
34 , blaze-builder >= 0.2.1.4 && < 0.4
34 , blaze-builder >= 0.2.1.4 && < 0.4
35+ , base64-bytestring >= 0.1 && < 0.2
36+ , cryptohash >= 0.7 && < 0.8
35 exposed-modules: Network.Wai.Application.Static
37 exposed-modules: Network.Wai.Application.Static
36 ghc-options: -Wall
38 ghc-options: -Wall
37 extensions: CPP
39 extensions: CPP