HTML writer: ensure headings only have valid attribs in HTML4
Fixes: #5944
This commit is contained in:
Albert Krewinkel
parent
4417dacc44
commit
25f5b92777
2 changed files with 71 additions and 54 deletions
|
|
@ -882,7 +882,7 @@ blockToHtml opts (BlockQuote blocks) = do
|
|||
else do
|
||||
contents <- blockListToHtml opts blocks
|
||||
return $ H.blockquote $ nl opts >> contents >> nl opts
|
||||
blockToHtml opts (Header level attr@(_,classes,kvs) lst) = do
|
||||
blockToHtml opts (Header level (ident,classes,kvs) lst) = do
|
||||
contents <- inlineListToHtml opts lst
|
||||
let secnum = fromMaybe mempty $ lookup "number" kvs
|
||||
let contents' = if writerNumberSections opts && not (T.null secnum)
|
||||
|
|
@ -890,7 +890,13 @@ blockToHtml opts (Header level attr@(_,classes,kvs) lst) = do
|
|||
then (H.span ! A.class_ "header-section-number"
|
||||
$ toHtml secnum) >> strToHtml " " >> contents
|
||||
else contents
|
||||
addAttrs opts attr
|
||||
html5 <- gets stHtml5
|
||||
let kvs' = if html5
|
||||
then kvs
|
||||
else [ (k, v) | (k, v) <- kvs
|
||||
, k `elem` (["lang", "dir", "title", "style"
|
||||
, "align"] ++ intrinsicEventsHTML4)]
|
||||
addAttrs opts (ident,classes,kvs')
|
||||
$ case level of
|
||||
1 -> H.h1 contents'
|
||||
2 -> H.h2 contents'
|
||||
|
|
@ -1526,6 +1532,12 @@ allowsMathEnvironments MathML = True
|
|||
allowsMathEnvironments (WebTeX _) = True
|
||||
allowsMathEnvironments _ = False
|
||||
|
||||
-- | List of intrinsic event attributes allowed on all elements in HTML4.
|
||||
intrinsicEventsHTML4 :: [Text]
|
||||
intrinsicEventsHTML4 =
|
||||
[ "onclick", "ondblclick", "onmousedown", "onmouseup", "onmouseover"
|
||||
, "onmouseout", "onmouseout", "onkeypress", "onkeydown", "onkeyup"]
|
||||
|
||||
isRawHtml :: PandocMonad m => Format -> StateT WriterState m Bool
|
||||
isRawHtml f = do
|
||||
html5 <- gets stHtml5
|
||||
|
|
|
|||
|
|
@ -34,55 +34,60 @@ infix 4 =:
|
|||
(=:) = test html
|
||||
|
||||
tests :: [TestTree]
|
||||
tests = [ testGroup "inline code"
|
||||
[ "basic" =: code "@&" =?> "<code>@&</code>"
|
||||
, "haskell" =: codeWith ("",["haskell"],[]) ">>="
|
||||
=?> "<code class=\"sourceCode haskell\"><span class=\"op\">>>=</span></code>"
|
||||
, "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>="
|
||||
=?> "<code class=\"nolanguage\">>>=</code>"
|
||||
]
|
||||
, testGroup "images"
|
||||
[ "alt with formatting" =:
|
||||
image "/url" "title" ("my " <> emph "image")
|
||||
=?> "<img src=\"/url\" title=\"title\" alt=\"my image\" />"
|
||||
]
|
||||
, testGroup "blocks"
|
||||
[ "definition list with empty <dt>" =:
|
||||
definitionList [(mempty, [para $ text "foo bar"])]
|
||||
=?> "<dl><dt></dt><dd><p>foo bar</p></dd></dl>"
|
||||
]
|
||||
, testGroup "quotes"
|
||||
[ "quote with cite attribute (without q-tags)" =:
|
||||
doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))
|
||||
=?> "“<span cite=\"http://example.org\">examples</span>”"
|
||||
, tQ "quote with cite attribute (with q-tags)" $
|
||||
doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))
|
||||
=?> "<q cite=\"http://example.org\">examples</q>"
|
||||
]
|
||||
, testGroup "sample"
|
||||
[ "sample should be rendered correctly" =:
|
||||
plain (codeWith ("",["sample"],[]) "Answer is 42") =?>
|
||||
"<samp>Answer is 42</samp>"
|
||||
]
|
||||
, testGroup "variable"
|
||||
[ "variable should be rendered correctly" =:
|
||||
plain (codeWith ("",["variable"],[]) "result") =?>
|
||||
"<var>result</var>"
|
||||
]
|
||||
, testGroup "sample with style"
|
||||
[ "samp should wrap highlighted code" =:
|
||||
codeWith ("",["sample","haskell"],[]) ">>="
|
||||
=?> ("<samp><code class=\"sourceCode haskell\">" ++
|
||||
"<span class=\"op\">>>=</span></code></samp>")
|
||||
]
|
||||
, testGroup "variable with style"
|
||||
[ "var should wrap highlighted code" =:
|
||||
codeWith ("",["haskell","variable"],[]) ">>="
|
||||
=?> ("<var><code class=\"sourceCode haskell\">" ++
|
||||
"<span class=\"op\">>>=</span></code></var>")
|
||||
]
|
||||
]
|
||||
where
|
||||
tQ :: (ToString a, ToPandoc a)
|
||||
=> String -> (a, String) -> TestTree
|
||||
tQ = test htmlQTags
|
||||
tests =
|
||||
[ testGroup "inline code"
|
||||
[ "basic" =: code "@&" =?> "<code>@&</code>"
|
||||
, "haskell" =: codeWith ("",["haskell"],[]) ">>="
|
||||
=?> "<code class=\"sourceCode haskell\"><span class=\"op\">>>=</span></code>"
|
||||
, "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>="
|
||||
=?> "<code class=\"nolanguage\">>>=</code>"
|
||||
]
|
||||
, testGroup "images"
|
||||
[ "alt with formatting" =:
|
||||
image "/url" "title" ("my " <> emph "image")
|
||||
=?> "<img src=\"/url\" title=\"title\" alt=\"my image\" />"
|
||||
]
|
||||
, testGroup "blocks"
|
||||
[ "definition list with empty <dt>" =:
|
||||
definitionList [(mempty, [para $ text "foo bar"])]
|
||||
=?> "<dl><dt></dt><dd><p>foo bar</p></dd></dl>"
|
||||
, "heading with disallowed attributes" =:
|
||||
headerWith ("", [], [("invalid","1"), ("lang", "en")]) 1 "test"
|
||||
=?>
|
||||
"<h1 lang=\"en\">test</h1>"
|
||||
]
|
||||
, testGroup "quotes"
|
||||
[ "quote with cite attribute (without q-tags)" =:
|
||||
doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))
|
||||
=?> "“<span cite=\"http://example.org\">examples</span>”"
|
||||
, tQ "quote with cite attribute (with q-tags)" $
|
||||
doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))
|
||||
=?> "<q cite=\"http://example.org\">examples</q>"
|
||||
]
|
||||
, testGroup "sample"
|
||||
[ "sample should be rendered correctly" =:
|
||||
plain (codeWith ("",["sample"],[]) "Answer is 42") =?>
|
||||
"<samp>Answer is 42</samp>"
|
||||
]
|
||||
, testGroup "variable"
|
||||
[ "variable should be rendered correctly" =:
|
||||
plain (codeWith ("",["variable"],[]) "result") =?>
|
||||
"<var>result</var>"
|
||||
]
|
||||
, testGroup "sample with style"
|
||||
[ "samp should wrap highlighted code" =:
|
||||
codeWith ("",["sample","haskell"],[]) ">>="
|
||||
=?> ("<samp><code class=\"sourceCode haskell\">" ++
|
||||
"<span class=\"op\">>>=</span></code></samp>")
|
||||
]
|
||||
, testGroup "variable with style"
|
||||
[ "var should wrap highlighted code" =:
|
||||
codeWith ("",["haskell","variable"],[]) ">>="
|
||||
=?> ("<var><code class=\"sourceCode haskell\">" ++
|
||||
"<span class=\"op\">>>=</span></code></var>")
|
||||
]
|
||||
]
|
||||
where
|
||||
tQ :: (ToString a, ToPandoc a)
|
||||
=> String -> (a, String) -> TestTree
|
||||
tQ = test htmlQTags
|
||||
|
|
|
|||
Loading…
Reference in a new issue