expose url re-writing function
This commit is contained in:
parent
3af64dd4cb
commit
b697998cc7
@ -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
|
||||||
|
|||||||
@ -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 =
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user