git.iko.soy/hakyll
on b287c82 help sign in
hakyll/src/Hakyll/Web/Html.hs
163 lines 4.9 kB history raw
1--------------------------------------------------------------------------------
2-- | Provides utilities to manipulate HTML pages
3module Hakyll.Web.Html
4 ( -- * Generic
5 withTags
7 -- * Headers
8 , demoteHeaders
10 -- * Url manipulation
11 , getUrls
12 , withUrls
13 , toUrl
14 , toSiteRoot
15 , isExternal
17 -- * Stripping/escaping
18 , stripTags
19 , escapeHtml
20 ) where
23--------------------------------------------------------------------------------
24import Data.Char (digitToInt, intToDigit,
25 isDigit, toLower)
26import Data.List (isPrefixOf)
27import qualified Data.Set as S
28import System.FilePath (joinPath, splitPath,
29 takeDirectory)
30import Text.Blaze.Html (toHtml)
31import Text.Blaze.Html.Renderer.String (renderHtml)
32import qualified Text.HTML.TagSoup as TS
35--------------------------------------------------------------------------------
36-- | Map over all tags in the document
37withTags :: (TS.Tag String -> TS.Tag String) -> String -> String
38withTags f = renderTags' . map f . TS.parseTags
41--------------------------------------------------------------------------------
42-- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc.
43demoteHeaders :: String -> String
44demoteHeaders = withTags $ \tag -> case tag of
45 TS.TagOpen t a -> TS.TagOpen (demote t) a
46 TS.TagClose t -> TS.TagClose (demote t)
47 t -> t
48 where
49 demote t@['h', n]
50 | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + 1)]
51 | otherwise = t
52 demote t = t
55--------------------------------------------------------------------------------
56isUrlAttribute :: String -> Bool
57isUrlAttribute = (`elem` ["src", "href"])
60--------------------------------------------------------------------------------
61getUrls :: [TS.Tag String] -> [String]
62getUrls tags = [v | TS.TagOpen _ as <- tags, (k, v) <- as, isUrlAttribute k]
65--------------------------------------------------------------------------------
66-- | Apply a function to each URL on a webpage
67withUrls :: (String -> String) -> String -> String
68withUrls f = withTags tag
69 where
70 tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a
71 tag x = x
72 attr (k, v) = (k, if isUrlAttribute k then f v else v)
75--------------------------------------------------------------------------------
76-- | Customized TagSoup renderer. The default TagSoup renderer escape CSS
77-- within style tags, and doesn't properly minimize.
78renderTags' :: [TS.Tag String] -> String
79renderTags' = TS.renderTagsOptions TS.renderOptions
80 { TS.optRawTag = (`elem` ["script", "style"]) . map toLower
81 , TS.optMinimize = (`S.member` minimize) . map toLower
82 }
83 where
84 -- A list of elements which must be minimized
85 minimize = S.fromList
86 [ "area", "br", "col", "embed", "hr", "img", "input", "meta", "link"
87 , "param"
88 ]
91--------------------------------------------------------------------------------
92-- | Convert a filepath to an URL starting from the site root
93--
94-- Example:
95--
96-- > toUrl "foo/bar.html"
97--
98-- Result:
99--
100-- > "/foo/bar.html"
101toUrl :: FilePath -> String
102toUrl ('/' : xs) = '/' : xs
103toUrl url = '/' : url
106--------------------------------------------------------------------------------
107-- | Get the relative url to the site root, for a given (absolute) url
108toSiteRoot :: String -> String
109toSiteRoot = emptyException . joinPath . map parent
110 . filter relevant . splitPath . takeDirectory
111 where
112 parent = const ".."
113 emptyException [] = "."
114 emptyException x = x
115 relevant "." = False
116 relevant "/" = False
117 relevant _ = True
120--------------------------------------------------------------------------------
121-- | Check if an URL links to an external HTTP(S) source
122isExternal :: String -> Bool
123isExternal url = any (flip isPrefixOf url) ["http://", "https://"]
126--------------------------------------------------------------------------------
127-- | Strip all HTML tags from a string
128--
129-- Example:
130--
131-- > stripTags "<p>foo</p>"
132--
133-- Result:
134--
135-- > "foo"
136--
137-- This also works for incomplete tags
138--
139-- Example:
140--
141-- > stripTags "<p>foo</p"
142--
143-- Result:
144--
145-- > "foo"
146stripTags :: String -> String
147stripTags [] = []
148stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs
149stripTags (x : xs) = x : stripTags xs
152--------------------------------------------------------------------------------
153-- | HTML-escape a string
154--
155-- Example:
156--
157-- > escapeHtml "Me & Dean"
158--
159-- Result:
160--
161-- > "Me &amp; Dean"
162escapeHtml :: String -> String
163escapeHtml = renderHtml . toHtml