{-# 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
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)
type Css = [(T.Text, [EithUrl])]
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)
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
Right Text
url ->
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)
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
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)
-> Location
-> FilePath
-> 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)) |]
}
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)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Word8 -> Parser Word8
PBL.word8 Word8
58
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)
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)
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
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
develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString))
[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