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
newtype UrlReference = UrlReference T.Text
deriving (Show, Eq, Hashable, Ord)
type EithUrl = (T.Text, Either T.Text UrlReference)
type Css = [(T.Text, [EithUrl])]
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)
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
Right url ->
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)
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
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)
-> Location
-> FilePath
-> 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)) |]
}
parseBackground :: Location -> FilePath -> PBL.Parser B.Builder
parseBackground loc file = do
void $ PBL.string "background-image"
s1 <- PBL.takeWhile (\x -> x == 32 || x == 9)
void $ PBL.word8 58
s2 <- PBL.takeWhile (\x -> x == 32 || x == 9)
void $ PBL.string "url('"
url <- PBL.takeWhile (/= 39)
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
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
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