diff --git a/Yesod/Static.hs b/Yesod/Static.hs --- a/Yesod/Static.hs +++ b/Yesod/Static.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------- -- -- | Serve static files from a Yesod app. @@ -35,6 +36,18 @@ , static , staticDevel , embed + -- * Combining CSS/JS + -- $combining + , combineStylesheets' + , combineScripts' + -- ** Settings + , CombineSettings + , csStaticDir + , csCssPostProcess + , csJsPostProcess + , csCssPreProcess + , csJsPreProcess + , csCombinedFolder -- * Template Haskell helpers , staticFiles , staticFilesList @@ -49,20 +62,19 @@ import Prelude hiding (FilePath) import qualified Prelude import System.Directory -import Control.Arrow (second) import Control.Monad import Data.FileEmbed (embedDir) -import Yesod.Core hiding (lift) +import Yesod.Core +import Yesod.Core.Types import Data.List (intercalate) import Language.Haskell.TH -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax as TH import Crypto.Conduit (hashFile, sinkHash) import Crypto.Hash.MD5 (MD5) import Control.Monad.Trans.State -import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Base64 import qualified Data.ByteString.Char8 as S8 @@ -70,19 +82,25 @@ import qualified Data.Serialize import Data.Text (Text, pack) import qualified Data.Text as T -import qualified Data.Set as S import qualified Data.Map as M import Data.IORef (readIORef, newIORef, writeIORef) -import Network.Wai (pathInfo) import Data.Char (isLower, isDigit) -import Data.List (foldl', inits, tails) +import Data.List (foldl') import qualified Data.ByteString as S import System.PosixCompat.Files (getFileStatus, modificationTime) import System.Posix.Types (EpochTime) -import Data.Conduit (($$)) -import Data.Conduit.List (sourceList) +import Data.Conduit +import Data.Conduit.List (sourceList, consume) +import Data.Conduit.Binary (sourceFile) +import qualified Data.Conduit.Text as CT import Data.Functor.Identity (runIdentity) import qualified Filesystem.Path.CurrentOS as F +import Filesystem.Path.CurrentOS ((), (<.>), FilePath) +import Filesystem (createTree) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Data.Default +import Text.Lucius (luciusRTMinified) import Network.Wai.Application.Static ( StaticSettings (..) @@ -146,10 +164,14 @@ data Route Static = StaticRoute [Text] [(Text, Text)] deriving (Eq, Show, Read) renderRoute (StaticRoute x y) = (x, y) +instance ParseRoute Static where + parseRoute (x, y) = Just $ StaticRoute x y -instance Yesod master => YesodDispatch Static master where - yesodDispatch _ _ (Static set) _ _ _ _ textPieces _ req = - staticApp set req { pathInfo = textPieces } +instance YesodSubDispatch Static m where + yesodSubDispatch YesodSubRunnerEnv {..} req = + staticApp set req + where + Static set = ysreGetSub $ yreSite $ ysreParentEnv notHidden :: Prelude.FilePath -> Bool notHidden "tmp" = False @@ -301,32 +323,14 @@ -> Bool -- ^ append checksum query parameter -> Q [Dec] mkStaticFilesList fp fs routeConName makeHash = do - let (squashedFinal, squashMap) = squashStrings ("etag" : concat fs) - (squashedName, squashedDecl) <- mkSquashedStringsDecl squashedFinal - let refName = mkSquashedReference squashedName squashMap - routes <- concat `fmap` mapM (mkRoute refName) fs - return (squashedDecl ++ routes) + concat `fmap` mapM mkRoute fs where replace' c | 'A' <= c && c <= 'Z' = c | 'a' <= c && c <= 'z' = c | '0' <= c && c <= '9' = c | otherwise = '_' - mkSquashedStringsDecl squashedFinal = do - name <- newName "squashedStrings" - pack' <- [|pack|] - squashedFinal' <- lift squashedFinal - let decl = [ SigD name (ConT ''Text) - , FunD name - [ Clause [] (NormalB $ pack' `AppE` squashedFinal') [] - ] - ] - return (name, decl) - mkSquashedReference squashedName squashMap = \str -> - case M.lookup str squashMap of - Nothing -> [|pack $(lift str)|] - Just (pos, len) -> [|T.take len (T.drop pos $(return (VarE squashedName)))|] - mkRoute refName f = do + mkRoute f = do let name' = intercalate "_" $ map (map replace') f routeName = mkName $ case () of @@ -335,11 +339,12 @@ | isDigit (head name') -> '_' : name' | isLower (head name') -> name' | otherwise -> '_' : name' - f' <- ListE `fmap` mapM refName f + f' <- [|map pack $(TH.lift f)|] let route = mkName routeConName + pack' <- [|pack|] qs <- if makeHash then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f - [|[($(refName "etag"), $(refName hash))]|] + [|[(pack "etag", pack $(TH.lift hash))]|] else return $ ListE [] return [ SigD routeName $ ConT route @@ -348,44 +353,6 @@ ] ] - --- | Convert a list of 'String's into a single 'String' and a --- 'M.Map' of the original 'String's into an offset and a length on --- the resulting single 'String'. -squashStrings :: [String] -> (String, M.Map String (Int, Int)) -squashStrings = second M.fromAscList . go 0 "" . S.toAscList . S.fromList - where - -- Length of the string of maximal length of characters from - -- the end of the @lastString@ that are the same. Uses a - -- naive algorithm. - calculateOverlap lastString newString = - let -- Make both strings of equal length. - len = length lastString `min` length newString - lastString' = reverse $ take len $ reverse lastString - newString' = take len newString - -- Using 'head' should be safe but we use another - -- version to avoid unuseful messages while debugging. - safeHead (x:_) = x - safeHead [] = error "squashStrings/overlap: never here" - in safeHead $ do - (lastStringSuffix, newStringPrefix) <- - tails lastString' `zip` reverse (inits newString') - guard (lastStringSuffix == newStringPrefix) - return (length lastStringSuffix) - - -- Position the new strings on the resulting string. - go lastPos lastString (newString:nss) = - let len = length newString - overlap = calculateOverlap lastString newString - thisPos = lastPos - overlap - newLastPos = lastPos + len - overlap - (recString, recMap) = go newLastPos newString nss - in ( drop overlap newString ++ recString - , (newString, (thisPos, len)) : recMap - ) - go _ _ [] = ([], []) - - base64md5File :: Prelude.FilePath -> IO String base64md5File = fmap (base64 . encode) . hashFile where encode d = Data.Serialize.encode (d :: MD5) @@ -407,3 +374,173 @@ tr '+' = '-' tr '/' = '_' tr c = c + +-- $combining +-- +-- A common scenario on a site is the desire to include many external CSS and +-- Javascript files on every page. Doing so via the Widget functionality in +-- Yesod will work, but would also mean that the same content will be +-- downloaded many times. A better approach would be to combine all of these +-- files together into a single static file and serve that as a static resource +-- for every page. That resource can be cached on the client, and bandwidth +-- usage reduced. +-- +-- This could be done as a manual process, but that becomes tedious. Instead, +-- you can use some Template Haskell code which will combine these files into a +-- single static file at compile time. + +data CombineType = JS | CSS + +combineStatics' :: CombineType + -> CombineSettings + -> [Route Static] -- ^ files to combine + -> Q Exp +combineStatics' combineType CombineSettings {..} routes = do + texts <- qRunIO $ runResourceT $ mapM_ yield fps $$ awaitForever readUTFFile =$ consume + ltext <- qRunIO $ preProcess $ TL.fromChunks texts + bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext + let hash' = base64md5 bs + suffix = csCombinedFolder F.decodeString hash' <.> extension + fp = csStaticDir suffix + qRunIO $ do + createTree $ F.directory fp + L.writeFile (F.encodeString fp) bs + let pieces = map T.unpack $ T.splitOn "/" $ either id id $ F.toText suffix + [|StaticRoute (map pack pieces) []|] + where + fps :: [F.FilePath] + fps = map toFP routes + toFP (StaticRoute pieces _) = csStaticDir F.concat (map F.fromText pieces) + readUTFFile fp = sourceFile (F.encodeString fp) =$= CT.decode CT.utf8 + postProcess = + case combineType of + JS -> csJsPostProcess + CSS -> csCssPostProcess + preProcess = + case combineType of + JS -> csJsPreProcess + CSS -> csCssPreProcess + extension = + case combineType of + JS -> "js" + CSS -> "css" + +-- | Data type for holding all settings for combining files. +-- +-- This data type is a settings type. For more information, see: +-- +-- +-- +-- Since 1.2.0 +data CombineSettings = CombineSettings + { csStaticDir :: F.FilePath + -- ^ File path containing static files. + -- + -- Default: static + -- + -- Since 1.2.0 + , csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString + -- ^ Post processing to be performed on CSS files. + -- + -- Default: Use Lucius to minify. + -- + -- Since 1.2.0 + , csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString + -- ^ Post processing to be performed on Javascript files. + -- + -- Default: Pass-through. + -- + -- Since 1.2.0 + , csCssPreProcess :: TL.Text -> IO TL.Text + -- ^ Pre-processing to be performed on CSS files. + -- + -- Default: convert all occurences of /static/ to ../ + -- + -- Since 1.2.0 + , csJsPreProcess :: TL.Text -> IO TL.Text + -- ^ Pre-processing to be performed on Javascript files. + -- + -- Default: Pass-through. + -- + -- Since 1.2.0 + , csCombinedFolder :: FilePath + -- ^ Subfolder to put combined files into. + -- + -- Default: combined + -- + -- Since 1.2.0 + } + +instance Default CombineSettings where + def = CombineSettings + { csStaticDir = "static" + , csCssPostProcess = \fps -> + either (error . (errorIntro fps)) (return . TLE.encodeUtf8) + . flip luciusRTMinified [] + . TLE.decodeUtf8 + , csJsPostProcess = const return + -- FIXME The following borders on a hack. With combining of files, + -- the final location of the CSS is no longer fixed, so relative + -- references will break. Instead, we switched to using /static/ + -- absolute references. However, when served from a separate domain + -- name, this will break too. The solution is that, during + -- development, we keep /static/, and in the combining phase, we + -- replace /static with a relative reference to the parent folder. + , csCssPreProcess = + return + . TL.replace "'/static/" "'../" + . TL.replace "\"/static/" "\"../" + , csJsPreProcess = return + , csCombinedFolder = "combined" + } + +errorIntro :: [FilePath] -> [Char] -> [Char] +errorIntro fps s = "Error minifying " ++ show fps ++ ": " ++ s + +liftRoutes :: [Route Static] -> Q Exp +liftRoutes = + fmap ListE . mapM go + where + go :: Route Static -> Q Exp + go (StaticRoute x y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|] + + liftTexts = fmap ListE . mapM liftT + liftT t = [|pack $(TH.lift $ T.unpack t)|] + + liftPairs = fmap ListE . mapM liftPair + liftPair (x, y) = [|($(liftT x), $(liftT y))|] + +-- | Combine multiple CSS files together. Common usage would be: +-- +-- >>> combineStylesheets' development def 'StaticR [style1_css, style2_css] +-- +-- Where @development@ is a variable in your site indicated whether you are in +-- development or production mode. +-- +-- Since 1.2.0 +combineStylesheets' :: Bool -- ^ development? if so, perform no combining + -> CombineSettings + -> Name -- ^ Static route constructor name, e.g. \'StaticR + -> [Route Static] -- ^ files to combine + -> Q Exp +combineStylesheets' development cs con routes + | development = [| mapM_ (addStylesheet . $(return $ ConE con)) $(liftRoutes routes) |] + | otherwise = [| addStylesheet $ $(return $ ConE con) $(combineStatics' CSS cs routes) |] + + +-- | Combine multiple JS files together. Common usage would be: +-- +-- >>> combineScripts' development def 'StaticR [script1_js, script2_js] +-- +-- Where @development@ is a variable in your site indicated whether you are in +-- development or production mode. +-- +-- Since 1.2.0 +combineScripts' :: Bool -- ^ development? if so, perform no combining + -> CombineSettings + -> Name -- ^ Static route constructor name, e.g. \'StaticR + -> [Route Static] -- ^ files to combine + -> Q Exp +combineScripts' development cs con routes + | development = [| mapM_ (addScript . $(return $ ConE con)) $(liftRoutes routes) |] + | otherwise = [| addScript $ $(return $ ConE con) $(combineStatics' JS cs routes) |] diff --git a/yesod-static.cabal b/yesod-static.cabal --- a/yesod-static.cabal +++ b/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.1.2.3 +version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -23,7 +23,7 @@ build-depends: base >= 4 && < 5 , containers >= 0.2 , old-time >= 1.0 - , yesod-core >= 1.1 && < 1.2 + , yesod-core >= 1.2 && < 1.3 , base64-bytestring >= 0.1.0.1 , cereal >= 0.3 , bytestring >= 0.9.1.4 @@ -40,6 +40,9 @@ , crypto-conduit >= 0.4 , cryptohash >= 0.6.1 , system-filepath >= 0.4.6 && < 0.5 + , system-fileio >= 0.3 + , data-default + , shakespeare-css >= 1.0.3 exposed-modules: Yesod.Static ghc-options: -Wall @@ -70,6 +73,9 @@ , crypto-conduit , cryptohash , system-filepath + , system-fileio + , data-default + , shakespeare-css ghc-options: -Wall