yesod-static 1.1.2.3 → 1.2.0
raw patch · 2 files changed
+217/−74 lines, 2 filesdep +data-defaultdep +shakespeare-cssdep +system-fileiodep ~yesod-core
Dependencies added: data-default, shakespeare-css, system-fileio
Dependency ranges changed: yesod-core
Files
- Yesod/Static.hs +209/−72
- yesod-static.cabal +8/−2
Yesod/Static.hs view
@@ -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:+--+-- <http://www.yesodweb.com/book/settings-types>+--+-- 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) |]
yesod-static.cabal view
@@ -1,5 +1,5 @@ name: yesod-static-version: 1.1.2.3+version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -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