yesod-static 1.2.2.5 → 1.2.3
raw patch · 3 files changed
+284/−1 lines, 3 filesdep +attoparsecdep +blaze-builderdep +css-text
Dependencies added: attoparsec, blaze-builder, css-text, hashable
Files
- Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs +80/−0
- Yesod/EmbeddedStatic/Css/Util.hs +196/−0
- yesod-static.cabal +8/−1
+ Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Manipulate CSS urls.+--+-- * Make relative urls absolute (useful when combining assets)+module Yesod.EmbeddedStatic.Css.AbsoluteUrl (+ -- * Absolute urls+ absoluteUrls+ , absoluteUrlsAt+ , absoluteUrlsWith+ , absCssUrlsFileProd+ , absCssUrlsProd+) where++import Prelude hiding (FilePath)+import Yesod.EmbeddedStatic.Generators+import Yesod.EmbeddedStatic.Types++import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy.Encoding as TL+import Control.Monad ((>=>))+import Data.Maybe (fromMaybe)+import Filesystem.Path.CurrentOS ((</>), collapse, FilePath, fromText, toText, encodeString, decodeString)++import Yesod.EmbeddedStatic.Css.Util++-------------------------------------------------------------------------------+-- Generator+-------------------------------------------------------------------------------++-- | Anchors relative CSS image urls+absCssUrlsFileProd :: FilePath -- ^ Anchor relative urls to here+ -> FilePath+ -> IO BL.ByteString+absCssUrlsFileProd dir file = do+ contents <- T.readFile (encodeString file)+ return $ TL.encodeUtf8 $ absCssUrlsProd dir contents++absCssUrlsProd :: FilePath -- ^ Anchor relative urls to here+ -> T.Text+ -> TL.Text+absCssUrlsProd dir contents =+ let css = either error id $ parseCssUrls contents+ in renderCssWith toAbsoluteUrl css+ where+ toAbsoluteUrl (UrlReference rel) = T.concat+ [ "url('/"+ , (either id id $ toText $ collapse $ dir </> fromText rel)+ , "')"+ ]+++-- | Equivalent to passing the same string twice to 'absoluteUrlsAt'.+absoluteUrls :: FilePath -> Generator+absoluteUrls f = absoluteUrlsAt (encodeString f) f++-- | Equivalent to passing @return@ to 'absoluteUrlsWith'.+absoluteUrlsAt :: Location -> FilePath -> Generator+absoluteUrlsAt loc f = absoluteUrlsWith loc f Nothing++-- | Automatically make relative urls absolute+--+-- During development, leave CSS as is.+--+-- When CSS is organized into a directory structure, it will work properly for individual requests for each file.+-- During production, we want to combine and minify CSS as much as possible.+-- The combination process combines files from different directories, messing up relative urls.+-- This pre-processor makes relative urls absolute+absoluteUrlsWith ::+ Location -- ^ The location the CSS file should appear in the static subsite+ -> FilePath -- ^ Path to the CSS file.+ -> Maybe (CssGeneration -> IO BL.ByteString) -- ^ Another filter function run after this one (for example @return . yuiCSS . cssContent@) or other CSS filter that runs after this filter.+ -> Generator+absoluteUrlsWith loc file mpostFilter =+ return [ cssProductionFilter (absCssUrlsFileProd (decodeString loc) >=> postFilter . mkCssGeneration loc file) loc file+ ]+ where+ postFilter = fromMaybe (return . cssContent) mpostFilter
+ Yesod/EmbeddedStatic/Css/Util.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving #-}+module Yesod.EmbeddedStatic.Css.Util where++import Prelude hiding (FilePath)+import Control.Applicative+import Control.Monad (void, foldM)+import Data.Hashable (Hashable)+import Data.Monoid+import Network.Mime (MimeType, defaultMimeLookup)+import Filesystem.Path.CurrentOS (FilePath, directory, (</>), dropExtension, filename, toText, decodeString, encodeString, fromText, absolute)+import Text.CSS.Parse (parseBlocks)+import Language.Haskell.TH (litE, stringL)+import Text.CSS.Render (renderBlocks)+import Yesod.EmbeddedStatic.Types+import Yesod.EmbeddedStatic (pathToName)+import Data.Default (def)++import qualified Blaze.ByteString.Builder as B+import qualified Blaze.ByteString.Builder.Char.Utf8 as B+import qualified Data.Attoparsec.Text as P+import qualified Data.Attoparsec.ByteString.Lazy as PBL+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Base64 as B64+import qualified Data.HashMap.Lazy as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TL++-------------------------------------------------------------------------------+-- Loading CSS+-------------------------------------------------------------------------------++-- | In the parsed CSS, this will be an image reference that we want to replace.+-- the contents will be the filepath.+newtype UrlReference = UrlReference T.Text+ deriving (Show, Eq, Hashable, Ord)++type EithUrl = (T.Text, Either T.Text UrlReference)++-- | The parsed CSS+type Css = [(T.Text, [EithUrl])]++-- | Parse the filename out of url('filename')+parseUrl :: P.Parser T.Text+parseUrl = do+ P.skipSpace+ void $ P.string "url('"+ P.takeTill (== '\'')++checkForUrl :: T.Text -> T.Text -> EithUrl+checkForUrl n@("background-image") v = parseBackgroundImage n v+checkForUrl n@("src") v = parseBackgroundImage n v+checkForUrl n v = (n, Left v)++-- | Check if a given CSS attribute is a background image referencing a local file+checkForImage :: T.Text -> T.Text -> EithUrl+checkForImage n@("background-image") v = parseBackgroundImage n v+checkForImage n v = (n, Left v)++parseBackgroundImage :: T.Text -> T.Text -> EithUrl+parseBackgroundImage n v = (n, case P.parseOnly parseUrl v of+ Left _ -> Left v -- Can't parse url+ Right url -> -- maybe we should find a uri parser+ if any (`T.isPrefixOf` url) ["http://", "https://", "//"] || absolute (fromText url)+ then Left v+ else Right $ UrlReference url)++parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css+parseCssWith urlParser contents =+ let mparsed = parseBlocks contents in+ case mparsed of+ Left err -> Left err+ Right blocks -> Right [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ]++parseCssUrls :: T.Text -> Either String Css+parseCssUrls = parseCssWith checkForUrl++parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css+parseCssFileWith urlParser fp = do+ mparsed <- parseCssWith urlParser <$> T.readFile (encodeString fp)+ case mparsed of+ Left err -> fail $ "Unable to parse " ++ encodeString fp ++ ": " ++ err+ Right css -> return css++parseCssFileUrls :: FilePath -> IO Css+parseCssFileUrls = parseCssFileWith checkForUrl++renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text+renderCssWith urlRenderer css =+ TL.toLazyText $ renderBlocks [(n, map render block) | (n,block) <- css]+ where+ render (n, Left b) = (n, b)+ render (n, Right f) = (n, urlRenderer f)++-- | Load an image map from the images in the CSS+loadImages :: FilePath -> Css -> (FilePath -> IO (Maybe a)) -> IO (M.HashMap UrlReference a)+loadImages dir css loadImage = foldM load M.empty $ concat [map snd block | (_,block) <- css]+ where+ load imap (Left _) = return imap+ load imap (Right f) | f `M.member` imap = return imap+ load imap (Right f@(UrlReference path)) = do+ img <- loadImage (dir </> fromText path)+ return $ maybe imap (\i -> M.insert f i imap) img+++-- | If you tack on additional CSS post-processing filters, they use this as an argument.+data CssGeneration = CssGeneration {+ cssContent :: BL.ByteString+ , cssStaticLocation :: Location+ , cssFileLocation :: FilePath+ }++mkCssGeneration :: Location -> FilePath -> BL.ByteString -> CssGeneration+mkCssGeneration loc file content =+ CssGeneration { cssContent = content+ , cssStaticLocation = loc+ , cssFileLocation = file+ }++cssProductionFilter ::+ (FilePath -> IO BL.ByteString) -- ^ a filter to be run on production+ -> Location -- ^ The location the CSS file should appear in the static subsite+ -> FilePath -- ^ Path to the CSS file.+ -> Entry+cssProductionFilter prodFilter loc file =+ def { ebHaskellName = Just $ pathToName loc+ , ebLocation = loc+ , ebMimeType = "text/css"+ , ebProductionContent = prodFilter file+ , ebDevelReload = [| develPassThrough $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |]+ , ebDevelExtraFiles = Nothing+ }++cssProductionImageFilter :: (FilePath -> IO BL.ByteString) -> Location -> FilePath -> Entry+cssProductionImageFilter prodFilter loc file =+ (cssProductionFilter prodFilter loc file)+ { ebDevelReload = [| develBgImgB64 $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |]+ , ebDevelExtraFiles = Just [| develExtraFiles $(litE (stringL loc)) |]+ }++-------------------------------------------------------------------------------+-- Helpers for the generators+-------------------------------------------------------------------------------++-- For development, all we need to do is update the background-image url to base64 encode it.+-- We want to preserve the formatting (whitespace+newlines) during development so we do not parse+-- using css-parse. Instead we write a simple custom parser.++parseBackground :: Location -> FilePath -> PBL.Parser B.Builder+parseBackground loc file = do+ void $ PBL.string "background-image"+ s1 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab+ void $ PBL.word8 58 -- colon+ s2 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab+ void $ PBL.string "url('"+ url <- PBL.takeWhile (/= 39) -- single quote+ void $ PBL.string "')"++ let b64 = B64.encode $ T.encodeUtf8 (either id id $ toText (directory file)) <> url+ newUrl = B.fromString (encodeString $ filename $ decodeString loc) <> B.fromString "/" <> B.fromByteString b64++ return $ B.fromByteString "background-image"+ <> B.fromByteString s1+ <> B.fromByteString ":"+ <> B.fromByteString s2+ <> B.fromByteString "url('"+ <> newUrl+ <> B.fromByteString "')"++parseDev :: Location -> FilePath -> B.Builder -> PBL.Parser B.Builder+parseDev loc file b = do+ b' <- parseBackground loc file <|> (B.fromWord8 <$> PBL.anyWord8)+ (PBL.endOfInput *> (pure $! b <> b')) <|> (parseDev loc file $! b <> b')++develPassThrough :: Location -> FilePath -> IO BL.ByteString+develPassThrough _ = BL.readFile . encodeString++-- | Create the CSS during development+develBgImgB64 :: Location -> FilePath -> IO BL.ByteString+develBgImgB64 loc file = do+ ct <- BL.readFile $ encodeString file+ case PBL.eitherResult $ PBL.parse (parseDev loc file mempty) ct of+ Left err -> error err+ Right b -> return $ B.toLazyByteString b++-- | Serve the extra image files during development+develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString))+develExtraFiles loc parts =+ case reverse parts of+ (file:dir) | T.pack loc == T.intercalate "/" (reverse dir) -> do+ let file' = T.decodeUtf8 $ B64.decodeLenient $ T.encodeUtf8 $ either id id $ toText $ dropExtension $ fromText file+ ct <- BL.readFile $ T.unpack file'+ return $ Just (defaultMimeLookup file', ct)+ _ -> return Nothing
yesod-static.cabal view
@@ -1,5 +1,5 @@ name: yesod-static-version: 1.2.2.5+version: 1.2.3 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -56,12 +56,19 @@ , process , async + , attoparsec >= 0.10+ , blaze-builder >= 0.3+ , css-text >= 0.1.2+ , hashable >= 1.1+ exposed-modules: Yesod.Static Yesod.EmbeddedStatic Yesod.EmbeddedStatic.Generators Yesod.EmbeddedStatic.Types+ Yesod.EmbeddedStatic.Css.AbsoluteUrl other-modules: Yesod.EmbeddedStatic.Internal+ Yesod.EmbeddedStatic.Css.Util ghc-options: -Wall extensions: TemplateHaskell