module Hakyll.Web.Html
(
withTags
, withTagList
, demoteHeaders
, getUrls
, withUrls
, toUrl
, toSiteRoot
, isExternal
, stripTags
, escapeHtml
) where
import Data.Char (digitToInt, intToDigit,
isDigit, toLower)
import Data.List (isPrefixOf)
import qualified Data.Set as S
import System.FilePath.Posix (joinPath, splitPath,
takeDirectory)
import Text.Blaze.Html (toHtml)
import Text.Blaze.Html.Renderer.String (renderHtml)
import qualified Text.HTML.TagSoup as TS
import Network.URI (isUnreserved, escapeURIString)
withTags :: (TS.Tag String -> TS.Tag String) -> String -> String
withTags :: (Tag String -> Tag String) -> String -> String
withTags = ([Tag String] -> [Tag String]) -> String -> String
withTagList (([Tag String] -> [Tag String]) -> String -> String)
-> ((Tag String -> Tag String) -> [Tag String] -> [Tag String])
-> (Tag String -> Tag String)
-> String
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag String -> Tag String) -> [Tag String] -> [Tag String]
forall a b. (a -> b) -> [a] -> [b]
map
withTagList :: ([TS.Tag String] -> [TS.Tag String]) -> String -> String
withTagList :: ([Tag String] -> [Tag String]) -> String -> String
withTagList f :: [Tag String] -> [Tag String]
f = [Tag String] -> String
renderTags' ([Tag String] -> String)
-> (String -> [Tag String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag String] -> [Tag String]
f ([Tag String] -> [Tag String])
-> (String -> [Tag String]) -> String -> [Tag String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Tag String]
parseTags'
demoteHeaders :: String -> String
= (Tag String -> Tag String) -> String -> String
withTags ((Tag String -> Tag String) -> String -> String)
-> (Tag String -> Tag String) -> String -> String
forall a b. (a -> b) -> a -> b
$ \tag :: Tag String
tag -> case Tag String
tag of
TS.TagOpen t :: String
t a :: [Attribute String]
a -> String -> [Attribute String] -> Tag String
forall str. str -> [Attribute str] -> Tag str
TS.TagOpen (String -> String
demote String
t) [Attribute String]
a
TS.TagClose t :: String
t -> String -> Tag String
forall str. str -> Tag str
TS.TagClose (String -> String
demote String
t)
t :: Tag String
t -> Tag String
t
where
demote :: String -> String
demote t :: String
t@['h', n :: Char
n]
| Char -> Bool
isDigit Char
n = ['h', Int -> Char
intToDigit (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min 6 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
digitToInt Char
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)]
| Bool
otherwise = String
t
demote t :: String
t = String
t
isUrlAttribute :: String -> Bool
isUrlAttribute :: String -> Bool
isUrlAttribute = (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["src", "href", "data", "poster", "srcset"])
getUrls :: [TS.Tag String] -> [String]
getUrls :: [Tag String] -> [String]
getUrls tags :: [Tag String]
tags = [String
v | TS.TagOpen _ as :: [Attribute String]
as <- [Tag String]
tags, (k :: String
k, v :: String
v) <- [Attribute String]
as, String -> Bool
isUrlAttribute String
k]
withUrls :: (String -> String) -> String -> String
withUrls :: (String -> String) -> String -> String
withUrls f :: String -> String
f = (Tag String -> Tag String) -> String -> String
withTags Tag String -> Tag String
tag
where
tag :: Tag String -> Tag String
tag (TS.TagOpen s :: String
s a :: [Attribute String]
a) = String -> [Attribute String] -> Tag String
forall str. str -> [Attribute str] -> Tag str
TS.TagOpen String
s ([Attribute String] -> Tag String)
-> [Attribute String] -> Tag String
forall a b. (a -> b) -> a -> b
$ (Attribute String -> Attribute String)
-> [Attribute String] -> [Attribute String]
forall a b. (a -> b) -> [a] -> [b]
map Attribute String -> Attribute String
attr [Attribute String]
a
tag x :: Tag String
x = Tag String
x
attr :: Attribute String -> Attribute String
attr (k :: String
k, v :: String
v) = (String
k, if String -> Bool
isUrlAttribute String
k then String -> String
f String
v else String
v)
renderTags' :: [TS.Tag String] -> String
renderTags' :: [Tag String] -> String
renderTags' = RenderOptions String -> [Tag String] -> String
forall str. StringLike str => RenderOptions str -> [Tag str] -> str
TS.renderTagsOptions RenderOptions :: forall str.
(str -> str) -> (str -> Bool) -> (str -> Bool) -> RenderOptions str
TS.RenderOptions
{ optRawTag :: String -> Bool
TS.optRawTag = (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["script", "style"]) (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
, optMinimize :: String -> Bool
TS.optMinimize = (String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set String
minimize) (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
, optEscape :: String -> String
TS.optEscape = String -> String
forall a. a -> a
id
}
where
minimize :: Set String
minimize = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList
[ "area", "br", "col", "embed", "hr", "img", "input", "meta", "link"
, "param"
]
parseTags' :: String -> [TS.Tag String]
parseTags' :: String -> [Tag String]
parseTags' = ParseOptions String -> String -> [Tag String]
forall str. StringLike str => ParseOptions str -> str -> [Tag str]
TS.parseTagsOptions (ParseOptions String
forall str. StringLike str => ParseOptions str
TS.parseOptions :: TS.ParseOptions String)
{ optEntityData :: (String, Bool) -> [Tag String]
TS.optEntityData = \(str :: String
str, b :: Bool
b) -> [String -> Tag String
forall str. str -> Tag str
TS.TagText (String -> Tag String) -> String -> Tag String
forall a b. (a -> b) -> a -> b
$ "&" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ [';' | Bool
b]]
, optEntityAttrib :: (String, Bool) -> (String, [Tag String])
TS.optEntityAttrib = \(str :: String
str, b :: Bool
b) -> ("&" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ [';' | Bool
b], [])
}
toUrl :: FilePath -> String
toUrl :: String -> String
toUrl url :: String
url = case String
url of
('/' : xs :: String
xs) -> '/' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
sanitize String
xs
xs :: String
xs -> '/' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
sanitize String
xs
where
sanitize :: String -> String
sanitize = (Char -> Bool) -> String -> String
escapeURIString (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/' Bool -> Bool -> Bool
|| Char -> Bool
isUnreserved Char
c)
toSiteRoot :: String -> String
toSiteRoot :: String -> String
toSiteRoot = String -> String
emptyException (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
joinPath ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall b. b -> String
parent
([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
relevant ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitPath (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeDirectory
where
parent :: b -> String
parent = String -> b -> String
forall a b. a -> b -> a
const ".."
emptyException :: String -> String
emptyException [] = "."
emptyException x :: String
x = String
x
relevant :: String -> Bool
relevant "." = Bool
False
relevant "/" = Bool
False
relevant "./" = Bool
False
relevant _ = Bool
True
isExternal :: String -> Bool
isExternal :: String -> Bool
isExternal url :: String
url = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> String -> Bool) -> String -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
url) ["http://", "https://", "//"]
stripTags :: String -> String
stripTags :: String -> String
stripTags [] = []
stripTags ('<' : xs :: String
xs) = String -> String
stripTags (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop 1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '>') String
xs
stripTags (x :: Char
x : xs :: String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
stripTags String
xs
escapeHtml :: String -> String
escapeHtml :: String -> String
escapeHtml = Html -> String
renderHtml (Html -> String) -> (String -> Html) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Html
forall a. ToMarkup a => a -> Html
toHtml