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.hs | 62 +++++++------- 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 ----------- 8 files changed, 232 insertions(+), 198 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') diff --git a/src/Hakyll.hs b/src/Hakyll.hs index 12f14bb..1131772 100644 --- a/src/Hakyll.hs +++ b/src/Hakyll.hs @@ -1,5 +1,5 @@ +-------------------------------------------------------------------------------- -- | Top-level module exporting all modules that are interesting for the user --- {-# LANGUAGE CPP #-} module Hakyll ( module Hakyll.Core.Compiler @@ -20,45 +20,45 @@ module Hakyll , module Hakyll.Main , module Hakyll.Web.CompressCss , module Hakyll.Web.Feed + , module Hakyll.Web.Html + , module Hakyll.Web.Html.RelativizeUrls , module Hakyll.Web.Pandoc , module Hakyll.Web.Pandoc.Biblio , module Hakyll.Web.Pandoc.FileType - , module Hakyll.Web.Urls - , module Hakyll.Web.Urls.Relativize , module Hakyll.Web.Tags , module Hakyll.Web.Template , module Hakyll.Web.Template.Context , module Hakyll.Web.Template.List , module Hakyll.Web.Template.Read - , module Hakyll.Web.Util.Html ) where -import Hakyll.Core.Compiler -import Hakyll.Core.Configuration -import Hakyll.Core.Identifier -import Hakyll.Core.Identifier.Pattern -import Hakyll.Core.Item -import Hakyll.Core.Metadata -import Hakyll.Core.Routes -import Hakyll.Core.Rules + +-------------------------------------------------------------------------------- +import Hakyll.Core.Compiler +import Hakyll.Core.Configuration +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Item +import Hakyll.Core.Metadata +import Hakyll.Core.Routes +import Hakyll.Core.Rules #ifdef UNIX_FILTER -import Hakyll.Core.UnixFilter +import Hakyll.Core.UnixFilter #endif -import Hakyll.Core.Util.File -import Hakyll.Core.Util.String -import Hakyll.Core.Writable -import Hakyll.Core.Writable.CopyFile -import Hakyll.Main -import Hakyll.Web.CompressCss -import Hakyll.Web.Feed -import Hakyll.Web.Pandoc -import Hakyll.Web.Pandoc.Biblio -import Hakyll.Web.Pandoc.FileType -import Hakyll.Web.Urls -import Hakyll.Web.Urls.Relativize -import Hakyll.Web.Tags -import Hakyll.Web.Template -import Hakyll.Web.Template.Context -import Hakyll.Web.Template.List -import Hakyll.Web.Template.Read -import Hakyll.Web.Util.Html +import Hakyll.Core.Util.File +import Hakyll.Core.Util.String +import Hakyll.Core.Writable +import Hakyll.Core.Writable.CopyFile +import Hakyll.Main +import Hakyll.Web.CompressCss +import Hakyll.Web.Feed +import Hakyll.Web.Html +import Hakyll.Web.Html.RelativizeUrls +import Hakyll.Web.Pandoc +import Hakyll.Web.Pandoc.Biblio +import Hakyll.Web.Pandoc.FileType +import Hakyll.Web.Tags +import Hakyll.Web.Template +import Hakyll.Web.Template.Context +import Hakyll.Web.Template.List +import Hakyll.Web.Template.Read 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