From 69ffbe03563cdbc7be6b826e2def2fc797442792 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 25 Dec 2012 22:49:17 +0100 Subject: Add demoteHeaders, refactor a bit --- src/Hakyll/Web/Html.hs | 147 ++++++++++++++++++++++++++++++++++ src/Hakyll/Web/Html/RelativizeUrls.hs | 52 ++++++++++++ src/Hakyll/Web/Tags.hs | 2 +- src/Hakyll/Web/Template/Context.hs | 2 +- src/Hakyll/Web/Urls.hs | 66 --------------- src/Hakyll/Web/Urls/Relativize.hs | 52 ------------ src/Hakyll/Web/Util/Html.hs | 47 ----------- 7 files changed, 201 insertions(+), 167 deletions(-) create mode 100644 src/Hakyll/Web/Html.hs create mode 100644 src/Hakyll/Web/Html/RelativizeUrls.hs delete mode 100644 src/Hakyll/Web/Urls.hs delete mode 100644 src/Hakyll/Web/Urls/Relativize.hs delete mode 100644 src/Hakyll/Web/Util/Html.hs (limited to 'src/Hakyll') diff --git a/src/Hakyll/Web/Html.hs b/src/Hakyll/Web/Html.hs new file mode 100644 index 0000000..3c94b2f --- /dev/null +++ b/src/Hakyll/Web/Html.hs @@ -0,0 +1,147 @@ +-------------------------------------------------------------------------------- +-- | Provides utilities to manipulate HTML pages +module Hakyll.Web.Html + ( -- * Generic + withTags + + -- * Headers + , demoteHeaders + + -- * Url manipulation + , withUrls + , toUrl + , toSiteRoot + , isExternal + + -- * Stripping/escaping + , stripTags + , escapeHtml + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (digitToInt, intToDigit, isDigit, toLower) +import Data.List (isPrefixOf) +import qualified Data.Set as S +import System.FilePath (joinPath, splitPath, takeDirectory) +import Text.Blaze.Html (toHtml) +import Text.Blaze.Html.Renderer.String (renderHtml) + + +-------------------------------------------------------------------------------- +import qualified Text.HTML.TagSoup as TS + + +-------------------------------------------------------------------------------- +-- | Map over all tags in the document +withTags :: (TS.Tag String -> TS.Tag String) -> String -> String +withTags f = renderTags' . map f . TS.parseTags + + +-------------------------------------------------------------------------------- +-- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc. +demoteHeaders :: String -> String +demoteHeaders = withTags $ \tag -> case tag of + TS.TagOpen t a -> TS.TagOpen (demote t) a + TS.TagClose t -> TS.TagClose (demote t) + t -> t + where + demote t@['h', n] + | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + 1)] + | otherwise = t + demote t = t + + +-------------------------------------------------------------------------------- +-- | Apply a function to each URL on a webpage +withUrls :: (String -> String) -> String -> String +withUrls f = withTags tag + where + tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a + tag x = x + attr (k, v) = (k, if k `S.member` refs then f v else v) + refs = S.fromList ["src", "href"] + + +-- | Customized TagSoup renderer. (The default TagSoup renderer escape CSS +-- within style tags.) +renderTags' :: [TS.Tag String] -> String +renderTags' = TS.renderTagsOptions TS.renderOptions + { TS.optRawTag = (`elem` ["script", "style"]) . map toLower + , TS.optMinimize = (`elem` ["br", "img"]) + } + + +-------------------------------------------------------------------------------- +-- | Convert a filepath to an URL starting from the site root +-- +-- Example: +-- +-- > toUrl "foo/bar.html" +-- +-- Result: +-- +-- > "/foo/bar.html" +toUrl :: FilePath -> String +toUrl ('/' : xs) = '/' : xs +toUrl url = '/' : url + + +-------------------------------------------------------------------------------- +-- | Get the relative url to the site root, for a given (absolute) url +toSiteRoot :: String -> String +toSiteRoot = emptyException . joinPath . map parent + . filter relevant . splitPath . takeDirectory + where + parent = const ".." + emptyException [] = "." + emptyException x = x + relevant "." = False + relevant "/" = False + relevant _ = True + + +-------------------------------------------------------------------------------- +-- | Check if an URL links to an external HTTP(S) source +isExternal :: String -> Bool +isExternal url = any (flip isPrefixOf url) ["http://", "https://"] + + +-------------------------------------------------------------------------------- +-- | Strip all HTML tags from a string +-- +-- Example: +-- +-- > stripTags "

foo

" +-- +-- Result: +-- +-- > "foo" +-- +-- This also works for incomplete tags +-- +-- Example: +-- +-- > stripTags "

foo "foo" +stripTags :: String -> String +stripTags [] = [] +stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs +stripTags (x : xs) = x : stripTags xs + + +-------------------------------------------------------------------------------- +-- | HTML-escape a string +-- +-- Example: +-- +-- > escapeHtml "Me & Dean" +-- +-- Result: +-- +-- > "Me & Dean" +escapeHtml :: String -> String +escapeHtml = renderHtml . toHtml diff --git a/src/Hakyll/Web/Html/RelativizeUrls.hs b/src/Hakyll/Web/Html/RelativizeUrls.hs new file mode 100644 index 0000000..33b0c2c --- /dev/null +++ b/src/Hakyll/Web/Html/RelativizeUrls.hs @@ -0,0 +1,52 @@ +-------------------------------------------------------------------------------- +-- | This module exposes a function which can relativize URL's on a webpage. +-- +-- This means that one can deploy the resulting site on +-- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@ +-- without having to change anything (simply copy over the files). +-- +-- To use it, you should use absolute URL's from the site root everywhere. For +-- example, use +-- +-- > Funny zomgroflcopter +-- +-- in a blogpost. When running this through the relativize URL's module, this +-- will result in (suppose your blogpost is located at @\/posts\/foo.html@: +-- +-- > Funny zomgroflcopter +module Hakyll.Web.Html.RelativizeUrls + ( relativizeUrls + , relativizeUrlsWith + ) where + + +-------------------------------------------------------------------------------- +import Data.List (isPrefixOf) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Compiler +import Hakyll.Core.Item +import Hakyll.Web.Html + + +-------------------------------------------------------------------------------- +-- | Compiler form of 'relativizeUrls' which automatically picks the right root +-- path +relativizeUrls :: Item String -> Compiler (Item String) +relativizeUrls item = do + route <- getRoute $ itemIdentifier item + return $ case route of + Nothing -> item + Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item + + +-------------------------------------------------------------------------------- +-- | Relativize URL's in HTML +relativizeUrlsWith :: String -- ^ Path to the site root + -> String -- ^ HTML to relativize + -> String -- ^ Resulting HTML +relativizeUrlsWith root = withUrls rel + where + isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x) + rel x = if isRel x then root ++ x else x diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index a2e4544..bf2b9d7 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -83,7 +83,7 @@ import Hakyll.Core.Metadata import Hakyll.Core.Rules import Hakyll.Core.Util.String import Hakyll.Web.Template.Context -import Hakyll.Web.Urls +import Hakyll.Web.Html -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs index c2ec6bc..7d359b4 100644 --- a/src/Hakyll/Web/Template/Context.hs +++ b/src/Hakyll/Web/Template/Context.hs @@ -40,7 +40,7 @@ import Hakyll.Core.Item import Hakyll.Core.Metadata import Hakyll.Core.Provider import Hakyll.Core.Util.String (splitAll) -import Hakyll.Web.Urls +import Hakyll.Web.Html -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Web/Urls.hs b/src/Hakyll/Web/Urls.hs deleted file mode 100644 index 1cd0816..0000000 --- a/src/Hakyll/Web/Urls.hs +++ /dev/null @@ -1,66 +0,0 @@ --- | Provides utilities to manipulate URL's --- -module Hakyll.Web.Urls - ( withUrls - , toUrl - , toSiteRoot - , isExternal - ) where - -import Data.List (isPrefixOf) -import Data.Char (toLower) -import System.FilePath (splitPath, takeDirectory, joinPath) -import qualified Data.Set as S - -import qualified Text.HTML.TagSoup as TS - --- | Apply a function to each URL on a webpage --- -withUrls :: (String -> String) -> String -> String -withUrls f = renderTags' . map tag . TS.parseTags - where - tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a - tag x = x - attr (k, v) = (k, if k `S.member` refs then f v else v) - refs = S.fromList ["src", "href"] - --- | Customized TagSoup renderer. (The default TagSoup renderer escape CSS --- within style tags.) --- -renderTags' :: [TS.Tag String] -> String -renderTags' = TS.renderTagsOptions TS.renderOptions - { TS.optRawTag = (`elem` ["script", "style"]) . map toLower - , TS.optMinimize = (`elem` ["br", "img"]) - } - --- | Convert a filepath to an URL starting from the site root --- --- Example: --- --- > toUrl "foo/bar.html" --- --- Result: --- --- > "/foo/bar.html" --- -toUrl :: FilePath -> String -toUrl ('/' : xs) = '/' : xs -toUrl url = '/' : url - --- | Get the relative url to the site root, for a given (absolute) url --- -toSiteRoot :: String -> String -toSiteRoot = emptyException . joinPath . map parent - . filter relevant . splitPath . takeDirectory - where - parent = const ".." - emptyException [] = "." - emptyException x = x - relevant "." = False - relevant "/" = False - relevant _ = True - --- | Check if an URL links to an external HTTP(S) source --- -isExternal :: String -> Bool -isExternal url = any (flip isPrefixOf url) ["http://", "https://"] diff --git a/src/Hakyll/Web/Urls/Relativize.hs b/src/Hakyll/Web/Urls/Relativize.hs deleted file mode 100644 index 321bbe3..0000000 --- a/src/Hakyll/Web/Urls/Relativize.hs +++ /dev/null @@ -1,52 +0,0 @@ --------------------------------------------------------------------------------- --- | This module exposes a function which can relativize URL's on a webpage. --- --- This means that one can deploy the resulting site on --- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@ --- without having to change anything (simply copy over the files). --- --- To use it, you should use absolute URL's from the site root everywhere. For --- example, use --- --- > Funny zomgroflcopter --- --- in a blogpost. When running this through the relativize URL's module, this --- will result in (suppose your blogpost is located at @\/posts\/foo.html@: --- --- > Funny zomgroflcopter -module Hakyll.Web.Urls.Relativize - ( relativizeUrls - , relativizeUrlsWith - ) where - - --------------------------------------------------------------------------------- -import Data.List (isPrefixOf) - - --------------------------------------------------------------------------------- -import Hakyll.Core.Compiler -import Hakyll.Core.Item -import Hakyll.Web.Urls - - --------------------------------------------------------------------------------- --- | Compiler form of 'relativizeUrls' which automatically picks the right root --- path -relativizeUrls :: Item String -> Compiler (Item String) -relativizeUrls item = do - route <- getRoute $ itemIdentifier item - return $ case route of - Nothing -> item - Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item - - --------------------------------------------------------------------------------- --- | Relativize URL's in HTML -relativizeUrlsWith :: String -- ^ Path to the site root - -> String -- ^ HTML to relativize - -> String -- ^ Resulting HTML -relativizeUrlsWith root = withUrls rel - where - isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x) - rel x = if isRel x then root ++ x else x diff --git a/src/Hakyll/Web/Util/Html.hs b/src/Hakyll/Web/Util/Html.hs deleted file mode 100644 index a413f84..0000000 --- a/src/Hakyll/Web/Util/Html.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | Miscellaneous HTML manipulation functions --- -module Hakyll.Web.Util.Html - ( stripTags - , escapeHtml - ) where - -import Text.Blaze.Html (toHtml) -import Text.Blaze.Html.Renderer.String (renderHtml) - --- | Strip all HTML tags from a string --- --- Example: --- --- > stripTags "

foo

" --- --- Result: --- --- > "foo" --- --- This also works for incomplete tags --- --- Example: --- --- > stripTags "

foo "foo" --- -stripTags :: String -> String -stripTags [] = [] -stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs -stripTags (x : xs) = x : stripTags xs - --- | HTML-escape a string --- --- Example: --- --- > escapeHtml "Me & Dean" --- --- Result: --- --- > "Me & Dean" --- -escapeHtml :: String -> String -escapeHtml = renderHtml . toHtml -- cgit v1.2.3