{-# 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 (Int -> UrlReference -> ShowS
[UrlReference] -> ShowS
UrlReference -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UrlReference] -> ShowS
$cshowList :: [UrlReference] -> ShowS
show :: UrlReference -> [Char]
$cshow :: UrlReference -> [Char]
showsPrec :: Int -> UrlReference -> ShowS
$cshowsPrec :: Int -> UrlReference -> ShowS
Show, UrlReference -> UrlReference -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UrlReference -> UrlReference -> Bool
$c/= :: UrlReference -> UrlReference -> Bool
== :: UrlReference -> UrlReference -> Bool
$c== :: UrlReference -> UrlReference -> Bool
Eq, Eq UrlReference
Int -> UrlReference -> Int
UrlReference -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: UrlReference -> Int
$chash :: UrlReference -> Int
hashWithSalt :: Int -> UrlReference -> Int
$chashWithSalt :: Int -> UrlReference -> Int
Hashable, Eq UrlReference
UrlReference -> UrlReference -> Bool
UrlReference -> UrlReference -> Ordering
UrlReference -> UrlReference -> UrlReference
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UrlReference -> UrlReference -> UrlReference
$cmin :: UrlReference -> UrlReference -> UrlReference
max :: UrlReference -> UrlReference -> UrlReference
$cmax :: UrlReference -> UrlReference -> UrlReference
>= :: UrlReference -> UrlReference -> Bool
$c>= :: UrlReference -> UrlReference -> Bool
> :: UrlReference -> UrlReference -> Bool
$c> :: UrlReference -> UrlReference -> Bool
<= :: UrlReference -> UrlReference -> Bool
$c<= :: UrlReference -> UrlReference -> Bool
< :: UrlReference -> UrlReference -> Bool
$c< :: UrlReference -> UrlReference -> Bool
compare :: UrlReference -> UrlReference -> Ordering
$ccompare :: UrlReference -> UrlReference -> Ordering
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 :: Parser Text
parseUrl = do
    Parser ()
P.skipSpace
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
P.string Text
"url('"
    (Char -> Bool) -> Parser Text
P.takeTill (forall a. Eq a => a -> a -> Bool
== Char
'\'')

checkForUrl :: T.Text -> T.Text -> EithUrl
checkForUrl :: Text -> Text -> EithUrl
checkForUrl n :: Text
n@(Text
"background-image") Text
v = Text -> Text -> EithUrl
parseBackgroundImage Text
n Text
v
checkForUrl n :: Text
n@(Text
"src") Text
v = Text -> Text -> EithUrl
parseBackgroundImage Text
n Text
v
checkForUrl Text
n Text
v = (Text
n, forall a b. a -> Either a b
Left Text
v)

-- | Check if a given CSS attribute is a background image referencing a local file
checkForImage :: T.Text -> T.Text -> EithUrl
checkForImage :: Text -> Text -> EithUrl
checkForImage n :: Text
n@(Text
"background-image") Text
v = Text -> Text -> EithUrl
parseBackgroundImage Text
n Text
v
checkForImage Text
n Text
v = (Text
n, forall a b. a -> Either a b
Left Text
v)

parseBackgroundImage :: T.Text -> T.Text -> EithUrl
parseBackgroundImage :: Text -> Text -> EithUrl
parseBackgroundImage Text
n Text
v = (Text
n, case forall a. Parser a -> Text -> Either [Char] a
P.parseOnly Parser Text
parseUrl Text
v of
    Left [Char]
_ -> forall a b. a -> Either a b
Left Text
v -- Can't parse url
    Right Text
url -> -- maybe we should find a uri parser
        if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
url) [Text
"http://", Text
"https://", Text
"/"]
            then forall a b. a -> Either a b
Left Text
v
            else forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> UrlReference
UrlReference Text
url)

parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css
parseCssWith :: (Text -> Text -> EithUrl) -> Text -> Either [Char] Css
parseCssWith Text -> Text -> EithUrl
urlParser Text
contents =
    let mparsed :: Either [Char] [CssBlock]
mparsed = Text -> Either [Char] [CssBlock]
parseBlocks Text
contents in
    case Either [Char] [CssBlock]
mparsed of
        Left [Char]
err -> forall a b. a -> Either a b
Left [Char]
err
        Right [CssBlock]
blocks -> forall a b. b -> Either a b
Right [ (Text
t, forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> EithUrl
urlParser) [(Text, Text)]
b) | (Text
t,[(Text, Text)]
b) <- [CssBlock]
blocks ]

parseCssUrls :: T.Text -> Either String Css
parseCssUrls :: Text -> Either [Char] Css
parseCssUrls = (Text -> Text -> EithUrl) -> Text -> Either [Char] Css
parseCssWith Text -> Text -> EithUrl
checkForUrl

parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css
parseCssFileWith :: (Text -> Text -> EithUrl) -> [Char] -> IO Css
parseCssFileWith Text -> Text -> EithUrl
urlParser [Char]
fp = do
    Either [Char] Css
mparsed <- (Text -> Text -> EithUrl) -> Text -> Either [Char] Css
parseCssWith Text -> Text -> EithUrl
urlParser forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
T.readFile [Char]
fp
    case Either [Char] Css
mparsed of
        Left [Char]
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Unable to parse " forall a. [a] -> [a] -> [a]
++ [Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char]
err
        Right Css
css -> forall (m :: * -> *) a. Monad m => a -> m a
return Css
css

parseCssFileUrls :: FilePath -> IO Css
parseCssFileUrls :: [Char] -> IO Css
parseCssFileUrls = (Text -> Text -> EithUrl) -> [Char] -> IO Css
parseCssFileWith Text -> Text -> EithUrl
checkForUrl

renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text
renderCssWith :: (UrlReference -> Text) -> Css -> Text
renderCssWith UrlReference -> Text
urlRenderer Css
css =
    Builder -> Text
TL.toLazyText forall a b. (a -> b) -> a -> b
$ [CssBlock] -> Builder
renderBlocks [(Text
n, forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (a, Either Text UrlReference) -> (a, Text)
render [EithUrl]
block) | (Text
n,[EithUrl]
block) <- Css
css]
  where
    render :: (a, Either Text UrlReference) -> (a, Text)
render (a
n, Left Text
b) = (a
n, Text
b)
    render (a
n, Right UrlReference
f) = (a
n, UrlReference -> Text
urlRenderer UrlReference
f)

-- | Load an image map from the images in the CSS
loadImages :: FilePath -> Css -> (FilePath -> IO (Maybe a)) -> IO (M.HashMap UrlReference a)
loadImages :: forall a.
[Char]
-> Css -> ([Char] -> IO (Maybe a)) -> IO (HashMap UrlReference a)
loadImages [Char]
dir Css
css [Char] -> IO (Maybe a)
loadImage = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {a}.
HashMap UrlReference a
-> Either a UrlReference -> IO (HashMap UrlReference a)
load forall k v. HashMap k v
M.empty forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [EithUrl]
block | (Text
_,[EithUrl]
block) <- Css
css]
    where
        load :: HashMap UrlReference a
-> Either a UrlReference -> IO (HashMap UrlReference a)
load HashMap UrlReference a
imap (Left a
_) = forall (m :: * -> *) a. Monad m => a -> m a
return HashMap UrlReference a
imap
        load HashMap UrlReference a
imap (Right UrlReference
f) | UrlReference
f forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`M.member` HashMap UrlReference a
imap = forall (m :: * -> *) a. Monad m => a -> m a
return HashMap UrlReference a
imap
        load HashMap UrlReference a
imap (Right f :: UrlReference
f@(UrlReference Text
path)) = do
            Maybe a
img <- [Char] -> IO (Maybe a)
loadImage ([Char]
dir [Char] -> ShowS
</> Text -> [Char]
T.unpack Text
path)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe HashMap UrlReference a
imap (\a
i -> forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert UrlReference
f a
i HashMap UrlReference a
imap) Maybe a
img


-- | If you tack on additional CSS post-processing filters, they use this as an argument.
data CssGeneration = CssGeneration {
                       CssGeneration -> ByteString
cssContent :: BL.ByteString
                     , CssGeneration -> [Char]
cssStaticLocation :: Location
                     , CssGeneration -> [Char]
cssFileLocation :: FilePath
                     }

mkCssGeneration :: Location -> FilePath -> BL.ByteString -> CssGeneration
mkCssGeneration :: [Char] -> [Char] -> ByteString -> CssGeneration
mkCssGeneration [Char]
loc [Char]
file ByteString
content =
    CssGeneration { cssContent :: ByteString
cssContent = ByteString
content
                  , cssStaticLocation :: [Char]
cssStaticLocation = [Char]
loc
                  , cssFileLocation :: [Char]
cssFileLocation = [Char]
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 :: ([Char] -> IO ByteString) -> [Char] -> [Char] -> Entry
cssProductionFilter [Char] -> IO ByteString
prodFilter [Char]
loc [Char]
file =
    forall a. Default a => a
def { ebHaskellName :: Maybe Name
ebHaskellName = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Name
pathToName [Char]
loc
        , ebLocation :: [Char]
ebLocation = [Char]
loc
        , ebMimeType :: ByteString
ebMimeType = ByteString
"text/css"
        , ebProductionContent :: IO ByteString
ebProductionContent = [Char] -> IO ByteString
prodFilter [Char]
file
        , ebDevelReload :: ExpQ
ebDevelReload = [| develPassThrough $(litE (stringL loc)) $(litE (stringL file)) |]
        , ebDevelExtraFiles :: Maybe ExpQ
ebDevelExtraFiles = forall a. Maybe a
Nothing
        }

cssProductionImageFilter :: (FilePath -> IO BL.ByteString) -> Location -> FilePath -> Entry
cssProductionImageFilter :: ([Char] -> IO ByteString) -> [Char] -> [Char] -> Entry
cssProductionImageFilter [Char] -> IO ByteString
prodFilter [Char]
loc [Char]
file =
  (([Char] -> IO ByteString) -> [Char] -> [Char] -> Entry
cssProductionFilter [Char] -> IO ByteString
prodFilter [Char]
loc [Char]
file)
    { ebDevelReload :: ExpQ
ebDevelReload = [| develBgImgB64 $(litE (stringL loc)) $(litE (stringL file)) |]
    , ebDevelExtraFiles :: Maybe ExpQ
ebDevelExtraFiles = forall a. a -> Maybe a
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 :: [Char] -> [Char] -> Parser Builder
parseBackground [Char]
loc [Char]
file = do
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString
PBL.string ByteString
"background-image"
    ByteString
s1 <- (Word8 -> Bool) -> Parser ByteString
PBL.takeWhile (\Word8
x -> Word8
x forall a. Eq a => a -> a -> Bool
== Word8
32 Bool -> Bool -> Bool
|| Word8
x forall a. Eq a => a -> a -> Bool
== Word8
9) -- space or tab
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Word8 -> Parser Word8
PBL.word8 Word8
58 -- colon
    ByteString
s2 <- (Word8 -> Bool) -> Parser ByteString
PBL.takeWhile (\Word8
x -> Word8
x forall a. Eq a => a -> a -> Bool
== Word8
32 Bool -> Bool -> Bool
|| Word8
x forall a. Eq a => a -> a -> Bool
== Word8
9) -- space or tab
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString
PBL.string ByteString
"url('"
    ByteString
url <- (Word8 -> Bool) -> Parser ByteString
PBL.takeWhile (forall a. Eq a => a -> a -> Bool
/= Word8
39) -- single quote
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString
PBL.string ByteString
"')"

    let b64 :: ByteString
b64 = ByteString -> ByteString
B64.encode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory [Char]
file) forall a. Semigroup a => a -> a -> a
<> ByteString
url
        newUrl :: Builder
newUrl = [Char] -> Builder
B.fromString (ShowS
takeFileName [Char]
loc) forall a. Semigroup a => a -> a -> a
<> [Char] -> Builder
B.fromString [Char]
"/" forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.fromByteString ByteString
b64

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.fromByteString ByteString
"background-image"
          forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.fromByteString ByteString
s1
          forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.fromByteString ByteString
":"
          forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.fromByteString ByteString
s2
          forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.fromByteString ByteString
"url('"
          forall a. Semigroup a => a -> a -> a
<> Builder
newUrl
          forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.fromByteString ByteString
"')"

parseDev :: Location -> FilePath -> B.Builder -> PBL.Parser B.Builder
parseDev :: [Char] -> [Char] -> Builder -> Parser Builder
parseDev [Char]
loc [Char]
file Builder
b = do
    Builder
b' <- [Char] -> [Char] -> Parser Builder
parseBackground [Char]
loc [Char]
file forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Word8 -> Builder
B.fromWord8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
PBL.anyWord8)
    (forall t. Chunk t => Parser t ()
PBL.endOfInput forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Builder
b forall a. Semigroup a => a -> a -> a
<> Builder
b')) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Char] -> [Char] -> Builder -> Parser Builder
parseDev [Char]
loc [Char]
file forall a b. (a -> b) -> a -> b
$! Builder
b forall a. Semigroup a => a -> a -> a
<> Builder
b')

develPassThrough :: Location -> FilePath -> IO BL.ByteString
develPassThrough :: [Char] -> [Char] -> IO ByteString
develPassThrough [Char]
_ = [Char] -> IO ByteString
BL.readFile

-- | Create the CSS during development
develBgImgB64 :: Location -> FilePath -> IO BL.ByteString
develBgImgB64 :: [Char] -> [Char] -> IO ByteString
develBgImgB64 [Char]
loc [Char]
file = do
    ByteString
ct <- [Char] -> IO ByteString
BL.readFile [Char]
file
    case forall r. Result r -> Either [Char] r
PBL.eitherResult forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Result a
PBL.parse ([Char] -> [Char] -> Builder -> Parser Builder
parseDev [Char]
loc [Char]
file forall a. Monoid a => a
mempty) ByteString
ct of
        Left [Char]
err -> forall a. HasCallStack => [Char] -> a
error [Char]
err
        Right Builder
b -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
B.toLazyByteString Builder
b

-- | Serve the extra image files during development
develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString))
develExtraFiles :: [Char] -> [Text] -> IO (Maybe (ByteString, ByteString))
develExtraFiles [Char]
loc [Text]
parts =
    case forall a. [a] -> [a]
reverse [Text]
parts of
        (Text
file:[Text]
dir) | [Char] -> Text
T.pack [Char]
loc forall a. Eq a => a -> a -> Bool
== Text -> [Text] -> Text
T.intercalate Text
"/" (forall a. [a] -> [a]
reverse [Text]
dir) -> do
            let file' :: Text
file' = ByteString -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.decodeLenient forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
file
            ByteString
ct <- [Char] -> IO ByteString
BL.readFile forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
file'
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text -> ByteString
defaultMimeLookup Text
file', ByteString
ct)
        [Text]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing