expose url re-writing function

This commit is contained in:
Greg Weber 2014-01-02 14:33:53 -08:00
parent 3af64dd4cb
commit b697998cc7
2 changed files with 31 additions and 16 deletions

View File

@ -7,6 +7,8 @@ module Yesod.EmbeddedStatic.Css.AbsoluteUrl (
absoluteUrls absoluteUrls
, absoluteUrlsAt , absoluteUrlsAt
, absoluteUrlsWith , absoluteUrlsWith
, absCssUrlsFileProd
, absCssUrlsProd
) where ) where
import Prelude hiding (FilePath) import Prelude hiding (FilePath)
@ -15,6 +17,7 @@ import Yesod.EmbeddedStatic.Types
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Text.Lazy.Encoding as TL
import Control.Monad ((>=>)) import Control.Monad ((>=>))
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -27,13 +30,20 @@ import Yesod.EmbeddedStatic.Css.Util
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | Anchors relative CSS image urls -- | Anchors relative CSS image urls
createAbsCssUrlsProd :: FilePath -- ^ Anchor relative urls to here absCssUrlsFileProd :: FilePath -- ^ Anchor relative urls to here
-> FilePath -> FilePath
-> IO BL.ByteString -> IO BL.ByteString
createAbsCssUrlsProd dir file = do absCssUrlsFileProd dir file = do
css <- parseCssUrls file contents <- T.readFile (encodeString file)
let r = renderCssWith toAbsoluteUrl css return $ absCssUrlsProd dir contents
return $ TL.encodeUtf8 r
absCssUrlsProd :: FilePath -- ^ Anchor relative urls to here
-> T.Text
-> BL.ByteString
absCssUrlsProd dir contents =
let css = either error id $ parseCssUrls contents
r = renderCssWith toAbsoluteUrl css
in TL.encodeUtf8 r
where where
toAbsoluteUrl (UrlReference rel) = T.concat toAbsoluteUrl (UrlReference rel) = T.concat
[ "url('/" [ "url('/"
@ -64,7 +74,7 @@ absoluteUrlsWith ::
-> 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. -> 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 -> Generator
absoluteUrlsWith loc file mpostFilter = absoluteUrlsWith loc file mpostFilter =
return [ cssProductionFilter (createAbsCssUrlsProd (decodeString loc) >=> postFilter . mkCssGeneration loc file) loc file return [ cssProductionFilter (absCssUrlsFileProd (decodeString loc) >=> postFilter . mkCssGeneration loc file) loc file
] ]
where where
postFilter = fromMaybe (return . cssContent) mpostFilter postFilter = fromMaybe (return . cssContent) mpostFilter

View File

@ -67,20 +67,25 @@ parseBackgroundImage n v = case P.parseOnly parseUrl v of
| "/" `T.isPrefixOf` url -> (n, Left v) | "/" `T.isPrefixOf` url -> (n, Left v)
| otherwise -> (n, Right $ UrlReference url) | otherwise -> (n, Right $ UrlReference url)
parseCssWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css
parseCssWith urlParser fp = do parseCssWith urlParser contents =
mparsed <- parseBlocks <$> T.readFile (encodeString fp) let mparsed = parseBlocks contents in
case mparsed of case mparsed of
Left err -> fail $ "Unable to parse " ++ encodeString fp ++ ": " ++ err Left err -> Left err
Right blocks -> Right blocks -> Right [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ]
return [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ]
parseCssUrls :: FilePath -> IO Css parseCssUrls :: T.Text -> Either String Css
parseCssUrls = parseCssWith checkForUrl parseCssUrls = parseCssWith checkForUrl
-- | Parse the CSS from the file. If a parse error occurs, a failure is raised (exception) parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css
parseCss :: FilePath -> IO Css parseCssFileWith urlParser fp = do
parseCss = parseCssWith checkForImage 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 :: (UrlReference -> T.Text) -> Css -> TL.Text
renderCssWith urlRenderer css = renderCssWith urlRenderer css =