196 lines
7.8 KiB
Haskell
196 lines
7.8 KiB
Haskell
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving #-}
|
|
module Yesod.EmbeddedStatic.Css.Util where
|
|
|
|
import Control.Applicative
|
|
import Control.Monad (void, foldM)
|
|
import Data.Hashable (Hashable)
|
|
import Data.Monoid
|
|
import Network.Mime (MimeType, defaultMimeLookup)
|
|
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 System.FilePath ((</>), takeFileName, takeDirectory, dropExtension)
|
|
|
|
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://", "/"]
|
|
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 fp
|
|
case mparsed of
|
|
Left err -> fail $ "Unable to parse " ++ 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 </> T.unpack 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 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 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 (T.pack $ takeDirectory file) <> url
|
|
newUrl = B.fromString (takeFileName 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
|
|
|
|
-- | Create the CSS during development
|
|
develBgImgB64 :: Location -> FilePath -> IO BL.ByteString
|
|
develBgImgB64 loc file = do
|
|
ct <- BL.readFile 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 $ T.pack $ dropExtension $ T.unpack file
|
|
ct <- BL.readFile $ T.unpack file'
|
|
return $ Just (defaultMimeLookup file', ct)
|
|
_ -> return Nothing
|