From e564147f2d13c78e2c2ed078436f31a7a8a1604c Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Mon, 28 Feb 2011 08:38:09 -0800 Subject: [PATCH] 2 kinds of static files- different cache headers * Forever - for "static" assets with a hash paremeter * ETag - for "public" assets without a hash parametes --- Yesod/Helpers/Static.hs | 276 +++++++++++++++++++++++++++------------- yesod-static.cabal | 4 + 2 files changed, 195 insertions(+), 85 deletions(-) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 37d24ee0..22c28e27 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -27,11 +27,16 @@ module Yesod.Helpers.Static ( -- * Subsite Static (..) + , Public (..) , StaticRoute (..) + , PublicRoute (..) -- * Smart constructor , static + , publicProduction + , publicDevel -- * Template Haskell helpers , staticFiles + , publicFiles {- -- * Embed files , getStaticHandler @@ -44,6 +49,7 @@ module Yesod.Helpers.Static ) where import System.Directory +import qualified System.Time import Control.Monad import Yesod.Handler @@ -63,8 +69,11 @@ import Data.Text (Text, pack) import Data.Monoid (mempty) import Network.Wai.Application.Static - ( defaultMimeTypeByExt, StaticSettings (..), staticAppPieces - , defaultListing + ( StaticSettings (..), CacheSettings (..) + , defaultStaticSettings, defaultPublicSettings + , staticAppPieces + , pathFromPieces + , Pieces ) #if TEST @@ -73,15 +82,51 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) #endif +-- | generally static assets referenced in html files +-- assets get a checksum query parameter appended for perfect caching +-- * a far future expire date is set +-- * a given asset revision will only ever be downloaded once (if the browser maintains its cache) +-- if you don't want to see a checksum in the url- use Public newtype Static = Static StaticSettings +-- | same as Static, but there is no checksum query parameter appended +-- generally html files and the favicon, but could be any file where you don't want the checksum parameter +-- * the file checksum is used for an ETag. +-- * this form of caching is not as good as the static- the browser can avoid downloading the file, but it always need to send a request with the etag value to the server to see if its copy is up to date +newtype Public = Public StaticSettings -- | Default value of 'Static' for a given file folder. -- -- Does not have index files, uses default directory listings and default mime -- type list. -static :: FilePath -> Static -static fp = Static $ StaticSettings fp [] (Just defaultListing) - (return . defaultMimeTypeByExt) +static :: String -> FilePath -> IO Static +static root fp = do + hashes <- mkHashMap fp + return $ Static $ (defaultStaticSettings (Forever $ isStaticRequest hashes)) { + ssFolder = fp + , ssMkRedirect = \_ newPath -> S8.pack $ root ++ "/" ++ newPath + } + where + isStaticRequest hashes reqf reqh = case M.lookup reqf hashes of + Nothing -> False + Just h -> h == reqh + +-- | no directory listing +public :: String -> FilePath -> CacheSettings -> Public +public root fp cache = Public $ (defaultPublicSettings cache) { + ssFolder = fp + , ssMkRedirect = \_ newPath -> S8.pack $ root ++ "/" ++ newPath + } + +publicProduction :: String -> FilePath -> IO Public +publicProduction root fp = do + etags <- mkPublicProductionEtag fp + return $ public root fp etags + +publicDevel :: String -> FilePath -> IO Public +publicDevel root fp = do + etags <- mkPublicDevelEtag fp + return $ public root fp etags + -- | Manually construct a static route. -- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string. @@ -92,16 +137,157 @@ static fp = Static $ StaticSettings fp [] (Just defaultListing) -- E.g. When generating image galleries. data StaticRoute = StaticRoute [Text] [(Text, Text)] deriving (Eq, Show, Read) +data PublicRoute = PublicRoute [String] [(String, String)] + deriving (Eq, Show, Read) type instance Route Static = StaticRoute +type instance Route Public = PublicRoute instance RenderRoute StaticRoute where renderRoute (StaticRoute x y) = (x, y) +instance RenderRoute PublicRoute where + renderRoute (PublicRoute x y) = (x, y) instance Yesod master => YesodDispatch Static master where yesodDispatch (Static set) _ pieces _ _ = Just $ staticAppPieces set pieces +instance Yesod master => YesodDispatch Public master where + yesodDispatch (Public set) _ pieces _ _ = + Just $ staticAppPieces set pieces + +notHidden :: FilePath -> Bool +notHidden ('.':_) = False +notHidden "tmp" = False +notHidden _ = True + +getFileListPieces :: FilePath -> IO [[String]] +getFileListPieces = flip go id + where + go :: String -> ([String] -> [String]) -> IO [[String]] + go fp front = do + allContents <- filter notHidden `fmap` getDirectoryContents fp + let fullPath :: String -> String + fullPath f = fp ++ '/' : f + files <- filterM (doesFileExist . fullPath) allContents + let files' = map (front . return) files + dirs <- filterM (doesDirectoryExist . fullPath) allContents + dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs + return $ concat $ files' : dirs' + +-- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: +-- +-- > style_css = StaticRoute ["style.css"] [] +-- > js_script_js = StaticRoute ["js/script.js"] [] +staticFiles :: FilePath -> Q [Dec] +staticFiles dir = mkStaticFiles dir StaticSite + +publicFiles :: FilePath -> Q [Dec] +publicFiles dir = mkStaticFiles dir PublicSite + +mkHashMap :: FilePath -> IO (M.Map FilePath S8.ByteString) +mkHashMap dir = do + fs <- getFileListPieces dir + hashAlist fs >>= return . M.fromList + where + hashAlist :: [Pieces] -> IO [(FilePath, S8.ByteString)] + hashAlist fs = mapM hashPair fs + where + hashPair :: Pieces -> IO (FilePath, S8.ByteString) + hashPair pieces = do let file = pathFromPieces dir pieces + h <- base64md5File file + return (file, S8.pack h) + +mkPublicDevelEtag :: FilePath -> IO CacheSettings +mkPublicDevelEtag dir = do + etags <- mkHashMap dir + mtimeVar <- newIORef (M.empty :: M.Map FilePath System.Time.ClockTime) + return $ ETag $ \f -> + case M.lookup f etags of + Nothing -> return Nothing + Just checksum -> do + newt <- getModificationTime f + mtimes <- readIORef mtimeVar + oldt <- case M.lookup f mtimes of + Nothing -> writeIORef mtimeVar (M.insert f newt mtimes) >> return newt + Just ot -> return ot + return $ if newt /= oldt then Nothing else Just checksum + + +mkPublicProductionEtag :: FilePath -> IO CacheSettings +mkPublicProductionEtag dir = do + etags <- mkHashMap dir + return $ ETag $ \f -> return . M.lookup f $ etags + +data StaticSite = StaticSite | PublicSite +mkStaticFiles :: FilePath -> StaticSite -> Q [Dec] +mkStaticFiles fp StaticSite = mkStaticFiles' fp "StaticRoute" True +mkStaticFiles fp PublicSite = mkStaticFiles' fp "PublicRoute" False + +mkStaticFiles' :: FilePath -> -- ^ static directory + String -> -- ^ route constructor "StaticRoute" + Bool -> -- ^ append checksum query parameter + Q [Dec] +mkStaticFiles' fp routeConName makeHash = do + fs <- qRunIO $ getFileListPieces fp + concat `fmap` mapM mkRoute fs + where + replace' c + | 'A' <= c && c <= 'Z' = c + | 'a' <= c && c <= 'z' = c + | '0' <= c && c <= '9' = c + | otherwise = '_' + mkRoute f = do + let name = mkName $ intercalate "_" $ map (map replace') f + f' <- [|map pack $(lift f)|] + let route = mkName routeConName + pack' <- [|pack|] + qs <- if makeHash + then do hash <- qRunIO $ base64md5File $ pathFromPieces fp f + [|[(pack $(lift hash), mempty)]|] + else return $ ListE [] + return + [ SigD name $ ConT route + , FunD name + [ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) [] + ] + ] + +base64md5File :: FilePath -> IO String +base64md5File file = do + contents <- L.readFile file + return $ base64md5 contents + +#if TEST + +testSuite :: Test +testSuite = testGroup "Yesod.Helpers.Static" + [ testCase "get file list" caseGetFileList + ] + +caseGetFileList :: Assertion +caseGetFileList = do + x <- getFileListPieces "test" + x @?= [["foo"], ["bar", "baz"]] + +#endif + +-- | md5-hashes the given lazy bytestring and returns the hash as +-- base64url-encoded string. +-- +-- This function returns the first 8 characters of the hash. +base64md5 :: L.ByteString -> String +base64md5 = map tr + . take 8 + . S8.unpack + . Data.ByteString.Base64.encode + . Data.Serialize.encode + . md5 + where + tr '+' = '-' + tr '/' = '_' + tr c = c + {- FIXME -- | Dispatch static route for a subsite -- @@ -124,83 +310,3 @@ getStaticHandler static toSubR pieces = do handler = fromMaybe notFound $ handleSite staticSite undefined route "GET" -} -notHidden :: FilePath -> Bool -notHidden ('.':_) = False -notHidden "tmp" = False -notHidden _ = True - -getFileList :: FilePath -> IO [[String]] -getFileList = flip go id - where - go :: String -> ([String] -> [String]) -> IO [[String]] - go fp front = do - allContents <- filter notHidden `fmap` getDirectoryContents fp - let fullPath :: String -> String - fullPath f = fp ++ '/' : f - files <- filterM (doesFileExist . fullPath) allContents - let files' = map (front . return) files - dirs <- filterM (doesDirectoryExist . fullPath) allContents - dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs - return $ concat $ files' : dirs' - --- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: --- --- > style_css = StaticRoute ["style.css"] [] --- > js_script_js = StaticRoute ["js/script.js"] [] -staticFiles :: FilePath -> Q [Dec] -staticFiles fp = do - fs <- qRunIO $ getFileList fp - concat `fmap` mapM go fs - where - replace' c - | 'A' <= c && c <= 'Z' = c - | 'a' <= c && c <= 'z' = c - | '0' <= c && c <= '9' = c - | otherwise = '_' - go f = do - let adjust [] = "" - adjust str@(x:xs) | isDigit x = '_' : x : xs - | isUpper x = toLower x : xs - | otherwise = str - let name = mkName $ intercalate "_" $ map (adjust . map replace') f - f' <- [|map pack $(lift f)|] - let sr = ConE $ mkName "StaticRoute" - hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f - pack' <- [|pack|] - qs <- [|[(pack $(lift hash), mempty)]|] - return - [ SigD name $ ConT ''Route `AppT` ConT ''Static - , FunD name - [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] - ] - ] - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Helpers.Static" - [ testCase "get file list" caseGetFileList - ] - -caseGetFileList :: Assertion -caseGetFileList = do - x <- getFileList "test" - x @?= [["foo"], ["bar", "baz"]] - -#endif - --- | md5-hashes the given lazy bytestring and returns the hash as --- base64url-encoded string. --- --- This function returns the first 8 characters of the hash. -base64md5 :: L.ByteString -> String -base64md5 = map go - . take 8 - . S8.unpack - . Data.ByteString.Base64.encode - . Data.Serialize.encode - . md5 - where - go '+' = '-' - go '/' = '_' - go c = c diff --git a/yesod-static.cabal b/yesod-static.cabal index a6c996cb..fd47681b 100644 --- a/yesod-static.cabal +++ b/yesod-static.cabal @@ -1,5 +1,9 @@ name: yesod-static +<<<<<<< HEAD version: 0.1.0 +======= +version: 0.1.0.0 +>>>>>>> update caching interface license: BSD3 license-file: LICENSE author: Michael Snoyman