2 kinds of static files- different cache headers
* Forever - for "static" assets with a hash paremeter * ETag - for "public" assets without a hash parametes
This commit is contained in:
Greg Weber
parent
97ab7ffa49
commit
e564147f2d
@ -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
|
||||
|
||||
@ -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 <michael@snoyman.com>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user