module Hakyll.Web.Html
(
withTags
, withTagList
, withTagListM
, demoteHeaders
, demoteHeadersBy
, getUrls
, withUrls
, toUrl
, toSiteRoot
, isExternal
, stripTags
, escapeHtml
) where
import Control.Monad (void)
import Control.Monad.Identity (Identity(runIdentity))
import Data.Char (digitToInt, intToDigit,
isDigit, toLower)
import Data.Either (fromRight)
import Data.List (isPrefixOf, intercalate)
import Data.Maybe (fromMaybe)
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.Parsec as P
import qualified Text.Parsec.Char as PC
import qualified Text.HTML.TagSoup as TS
import Network.URI (isUnreserved, escapeURIString)
import Hakyll.Core.Util.String (removeWinPathSeparator)
withTags :: (TS.Tag String -> TS.Tag String) -> String -> String
withTags :: (Tag String -> Tag String) -> String -> String
withTags = ([Tag String] -> [Tag String]) -> String -> String
withTagList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 [Tag String] -> [Tag String]
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
([Tag String] -> m [Tag String]) -> String -> m String
withTagListM (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag String] -> [Tag String]
f)
withTagListM :: Monad m => ([TS.Tag String] -> m [TS.Tag String]) -> String -> m String
withTagListM :: forall (m :: * -> *).
Monad m =>
([Tag String] -> m [Tag String]) -> String -> m String
withTagListM [Tag String] -> m [Tag String]
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Tag String] -> String
renderTags' forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag String] -> m [Tag String]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Tag String]
parseTags'
{-# INLINE withTagListM #-}
demoteHeaders :: String -> String
= Int -> String -> String
demoteHeadersBy Int
1
demoteHeadersBy :: Int -> String -> String
Int
amount
| Int
amount forall a. Ord a => a -> a -> Bool
< Int
1 = forall a. a -> a
id
| Bool
otherwise = (Tag String -> Tag String) -> String -> String
withTags forall a b. (a -> b) -> a -> b
$ \Tag String
tag -> case Tag String
tag of
TS.TagOpen String
t [Attribute String]
a -> forall str. str -> [Attribute str] -> Tag str
TS.TagOpen (String -> String
demote String
t) [Attribute String]
a
TS.TagClose String
t -> forall str. str -> Tag str
TS.TagClose (String -> String
demote String
t)
Tag String
t -> Tag String
t
where
demote :: String -> String
demote t :: String
t@[Char
'h', Char
n]
| Char -> Bool
isDigit Char
n = [Char
'h', Int -> Char
intToDigit (forall a. Ord a => a -> a -> a
min Int
6 forall a b. (a -> b) -> a -> b
$ Char -> Int
digitToInt Char
n forall a. Num a => a -> a -> a
+ Int
amount)]
| Bool
otherwise = String
t
demote String
t = String
t
isUrlAttribute :: String -> Bool
isUrlAttribute :: String -> Bool
isUrlAttribute = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"src", String
"href", String
"data", String
"poster"])
getUrls :: [TS.Tag String] -> [String]
getUrls :: [Tag String] -> [String]
getUrls [Tag String]
tags = [String
u | TS.TagOpen String
_ [Attribute String]
as <- [Tag String]
tags, (String
k, String
v) <- [Attribute String]
as, String
u <- String -> String -> [String]
extractUrls String
k String
v]
where
extractUrls :: String -> String -> [String]
extractUrls String
"srcset" String
value =
let srcset :: Either ParseError [SrcsetImageCandidate]
srcset = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Srcset -> [SrcsetImageCandidate]
unSrcset forall a b. (a -> b) -> a -> b
$ forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse Parsec String () Srcset
srcsetParser String
"" String
value
in forall a b. (a -> b) -> [a] -> [b]
map SrcsetImageCandidate -> String
srcsetImageCandidateUrl forall a b. (a -> b) -> a -> b
$ forall b a. b -> Either a b -> b
fromRight [] Either ParseError [SrcsetImageCandidate]
srcset
extractUrls String
key String
value
| String -> Bool
isUrlAttribute String
key = [String
value]
| Bool
otherwise = []
withUrls :: (String -> String) -> String -> String
withUrls :: (String -> String) -> String -> String
withUrls String -> String
f = (Tag String -> Tag String) -> String -> String
withTags Tag String -> Tag String
tag
where
tag :: Tag String -> Tag String
tag (TS.TagOpen String
s [Attribute String]
a) = forall str. str -> [Attribute str] -> Tag str
TS.TagOpen String
s forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Attribute String -> Attribute String
attr [Attribute String]
a
tag Tag String
x = Tag String
x
attr :: Attribute String -> Attribute String
attr input :: Attribute String
input@(String
"srcset", String
v) =
case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Srcset -> [SrcsetImageCandidate]
unSrcset forall a b. (a -> b) -> a -> b
$ forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse Parsec String () Srcset
srcsetParser String
"" String
v of
Right [SrcsetImageCandidate]
srcset ->
let srcset' :: [SrcsetImageCandidate]
srcset' = forall a b. (a -> b) -> [a] -> [b]
map (\SrcsetImageCandidate
i -> SrcsetImageCandidate
i { srcsetImageCandidateUrl :: String
srcsetImageCandidateUrl = String -> String
f forall a b. (a -> b) -> a -> b
$ SrcsetImageCandidate -> String
srcsetImageCandidateUrl SrcsetImageCandidate
i }) [SrcsetImageCandidate]
srcset
srcset'' :: String
srcset'' = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ [SrcsetImageCandidate] -> Srcset
Srcset [SrcsetImageCandidate]
srcset'
in (String
"srcset", String
srcset'')
Left ParseError
_ -> Attribute String
input
attr (String
k, 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' = forall str. StringLike str => RenderOptions str -> [Tag str] -> str
TS.renderTagsOptions TS.RenderOptions
{ optRawTag :: String -> Bool
TS.optRawTag = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"script", String
"style"]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
, optMinimize :: String -> Bool
TS.optMinimize = (forall a. Ord a => a -> Set a -> Bool
`S.member` Set String
minimize) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
, optEscape :: String -> String
TS.optEscape = forall a. a -> a
id
}
where
minimize :: Set String
minimize = forall a. Ord a => [a] -> Set a
S.fromList
[ String
"area", String
"br", String
"col", String
"embed", String
"hr", String
"img", String
"input", String
"meta", String
"link"
, String
"param"
]
parseTags' :: String -> [TS.Tag String]
parseTags' :: String -> [Tag String]
parseTags' = forall str. StringLike str => ParseOptions str -> str -> [Tag str]
TS.parseTagsOptions (forall str. StringLike str => ParseOptions str
TS.parseOptions :: TS.ParseOptions String)
{ optEntityData :: (String, Bool) -> [Tag String]
TS.optEntityData = \(String
str, Bool
b) -> [forall str. str -> Tag str
TS.TagText forall a b. (a -> b) -> a -> b
$ String
"&" forall a. [a] -> [a] -> [a]
++ String
str forall a. [a] -> [a] -> [a]
++ [Char
';' | Bool
b]]
, optEntityAttrib :: (String, Bool) -> (String, [Tag String])
TS.optEntityAttrib = \(String
str, Bool
b) -> (String
"&" forall a. [a] -> [a] -> [a]
++ String
str forall a. [a] -> [a] -> [a]
++ [Char
';' | Bool
b], [])
}
toUrl :: FilePath -> String
toUrl :: String -> String
toUrl String
url = case (String -> String
removeWinPathSeparator String
url) of
(Char
'/' : String
xs) -> Char
'/' forall a. a -> [a] -> [a]
: String -> String
sanitize String
xs
String
xs -> Char
'/' forall a. a -> [a] -> [a]
: String -> String
sanitize String
xs
where
sanitize :: String -> String
sanitize = (Char -> Bool) -> String -> String
escapeURIString (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
|| Char -> Bool
isUnreserved Char
c)
toSiteRoot :: String -> String
toSiteRoot :: String -> String
toSiteRoot = String -> String
removeWinPathSeparator forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
emptyException forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
joinPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {b}. b -> String
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
relevant forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeDirectory
where
parent :: b -> String
parent = forall a b. a -> b -> a
const String
".."
emptyException :: String -> String
emptyException [] = String
"."
emptyException String
x = String
x
relevant :: String -> Bool
relevant String
"." = Bool
False
relevant String
"/" = Bool
False
relevant String
"./" = Bool
False
relevant String
_ = Bool
True
isExternal :: String -> Bool
isExternal :: String -> Bool
isExternal String
url = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
url) [String
"http://", String
"https://", String
"//"]
stripTags :: String -> String
stripTags :: String -> String
stripTags [] = []
stripTags (Char
'<' : String
xs) = String -> String
stripTags forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'>') String
xs
stripTags (Char
x : String
xs) = Char
x forall a. a -> [a] -> [a]
: String -> String
stripTags String
xs
escapeHtml :: String -> String
escapeHtml :: String -> String
escapeHtml = Html -> String
renderHtml forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMarkup a => a -> Html
toHtml
data Srcset = Srcset {
Srcset -> [SrcsetImageCandidate]
unSrcset :: [SrcsetImageCandidate]
}
instance Show Srcset where
show :: Srcset -> String
show Srcset
set = forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Srcset -> [SrcsetImageCandidate]
unSrcset Srcset
set
data SrcsetImageCandidate = SrcsetImageCandidate {
SrcsetImageCandidate -> String
srcsetImageCandidateUrl :: String
, SrcsetImageCandidate -> Maybe String
srcsetImageCandidateDescriptor :: Maybe String
}
instance Show SrcsetImageCandidate where
show :: SrcsetImageCandidate -> String
show SrcsetImageCandidate
candidate =
let url :: String
url = SrcsetImageCandidate -> String
srcsetImageCandidateUrl SrcsetImageCandidate
candidate
in case SrcsetImageCandidate -> Maybe String
srcsetImageCandidateDescriptor SrcsetImageCandidate
candidate of
Just String
desc -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
url, String
" ", String
desc]
Maybe String
Nothing -> String
url
srcsetParser :: P.Parsec String () Srcset
srcsetParser :: Parsec String () Srcset
srcsetParser = do
[SrcsetImageCandidate]
result <- Parsec String () SrcsetImageCandidate
candidate forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`P.sepBy1` (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
PC.char Char
',')
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [SrcsetImageCandidate] -> Srcset
Srcset [SrcsetImageCandidate]
result
where
candidate :: P.Parsec String () SrcsetImageCandidate
candidate :: Parsec String () SrcsetImageCandidate
candidate = do
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
P.skipMany Parsec String () ()
ascii_whitespace
String
u <- Parsec String () String
url
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
P.skipMany Parsec String () ()
ascii_whitespace
Maybe String
desc <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
P.choice forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try [Parsec String () String
width_descriptor, Parsec String () String
px_density_descriptor]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
P.skipMany Parsec String () ()
ascii_whitespace
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SrcsetImageCandidate {
srcsetImageCandidateUrl :: String
srcsetImageCandidateUrl = String
u
, srcsetImageCandidateDescriptor :: Maybe String
srcsetImageCandidateDescriptor = Maybe String
desc
}
url :: P.Parsec String () String
url :: Parsec String () String
url = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
PC.noneOf String
" ,"
ascii_whitespace :: P.Parsec String () ()
ascii_whitespace :: Parsec String () ()
ascii_whitespace = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
P.oneOf String
"\x09\x0A\x0C\x0D\x20"
width_descriptor :: P.Parsec String () String
width_descriptor :: Parsec String () String
width_descriptor = do
String
number <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
PC.digit
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
PC.char Char
'w'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
number, String
"w"]
px_density_descriptor :: P.Parsec String () String
px_density_descriptor :: Parsec String () String
px_density_descriptor = do
Maybe Char
sign <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
PC.char Char
'-'
String
int <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
PC.digit
Maybe String
frac <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
PC.char Char
'.'
String
frac <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
PC.digit
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
".", String
frac]
Maybe String
expon <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe forall a b. (a -> b) -> a -> b
$ do
Char
letter <- forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
P.oneOf String
"eE"
Maybe Char
e_sign <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
PC.oneOf String
"-+"
String
number <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
PC.digit
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char
letter], Maybe String -> String
mb forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> String
show Maybe Char
e_sign, String
number]
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
PC.char Char
'x'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Maybe String -> String
mb forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> String
show Maybe Char
sign, String
int, Maybe String -> String
mb Maybe String
frac, Maybe String -> String
mb Maybe String
expon, String
"x"]
mb :: Maybe String -> String
mb :: Maybe String -> String
mb = forall a. a -> Maybe a -> a
fromMaybe String
""