git.iko.soy/typeable/pandoc
on master help sign in
HTML writer: ensure headings only have valid attribs in HTML4

Fixes: #5944

commit25f5b927773eb730c2d5ef834bd61e1d2d5f09df authorAlbert Krewinkel <albert@zeitkraut.de> dateMon 17 May 2021, 15:37 (5 years ago) parent4417dac
2 files changed+71−54
compare with master
unifiedsplit
src/Text/Pandoc/Writers/HTML.hs+14−2 test/Tests/Writers/HTML.hs+57−52
src/Text/Pandoc/Writers/HTML.hs+14−2
@@ -882,7 +882,7 @@ blockToHtml opts (BlockQuote blocks) = do
882882 else do
883883 contents <- blockListToHtml opts blocks
884884 return $ H.blockquote $ nl opts >> contents >> nl opts
885−blockToHtml opts (Header level attr@(_,classes,kvs) lst) = do
885+blockToHtml opts (Header level (ident,classes,kvs) lst) = do
886886 contents <- inlineListToHtml opts lst
887887 let secnum = fromMaybe mempty $ lookup "number" kvs
888888 let contents' = if writerNumberSections opts && not (T.null secnum)
@@ -890,7 +890,13 @@ blockToHtml opts (Header level attr@(_,classes,kvs) lst) = do
890890 then (H.span ! A.class_ "header-section-number"
891891 $ toHtml secnum) >> strToHtml " " >> contents
892892 else contents
893− addAttrs opts attr
893+ html5 <- gets stHtml5
894+ let kvs' = if html5
895+ then kvs
896+ else [ (k, v) | (k, v) <- kvs
897+ , k `elem` (["lang", "dir", "title", "style"
898+ , "align"] ++ intrinsicEventsHTML4)]
899+ addAttrs opts (ident,classes,kvs')
894900 $ case level of
895901 1 -> H.h1 contents'
896902 2 -> H.h2 contents'
@@ -1526,6 +1532,12 @@ allowsMathEnvironments MathML = True
15261532allowsMathEnvironments (WebTeX _) = True
15271533allowsMathEnvironments _ = False
15281534
1535+-- | List of intrinsic event attributes allowed on all elements in HTML4.
1536+intrinsicEventsHTML4 :: [Text]
1537+intrinsicEventsHTML4 =
1538+ [ "onclick", "ondblclick", "onmousedown", "onmouseup", "onmouseover"
1539+ , "onmouseout", "onmouseout", "onkeypress", "onkeydown", "onkeyup"]
1540+
15291541isRawHtml :: PandocMonad m => Format -> StateT WriterState m Bool
15301542isRawHtml f = do
15311543 html5 <- gets stHtml5
test/Tests/Writers/HTML.hs+57−52
@@ -34,55 +34,60 @@ infix 4 =:
3434(=:) = test html
3535
3636tests :: [TestTree]
37−tests = [ testGroup "inline code"
38− [ "basic" =: code "@&" =?> "<code>@&amp;</code>"
39− , "haskell" =: codeWith ("",["haskell"],[]) ">>="
40− =?> "<code class=\"sourceCode haskell\"><span class=\"op\">&gt;&gt;=</span></code>"
41− , "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>="
42− =?> "<code class=\"nolanguage\">&gt;&gt;=</code>"
43− ]
44− , testGroup "images"
45− [ "alt with formatting" =:
46− image "/url" "title" ("my " <> emph "image")
47− =?> "<img src=\"/url\" title=\"title\" alt=\"my image\" />"
48− ]
49− , testGroup "blocks"
50− [ "definition list with empty <dt>" =:
51− definitionList [(mempty, [para $ text "foo bar"])]
52− =?> "<dl><dt></dt><dd><p>foo bar</p></dd></dl>"
53− ]
54− , testGroup "quotes"
55− [ "quote with cite attribute (without q-tags)" =:
56− doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))
57− =?> "“<span cite=\"http://example.org\">examples</span>”"
58− , tQ "quote with cite attribute (with q-tags)" $
59− doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))
60− =?> "<q cite=\"http://example.org\">examples</q>"
61− ]
62− , testGroup "sample"
63− [ "sample should be rendered correctly" =:
64− plain (codeWith ("",["sample"],[]) "Answer is 42") =?>
65− "<samp>Answer is 42</samp>"
66− ]
67− , testGroup "variable"
68− [ "variable should be rendered correctly" =:
69− plain (codeWith ("",["variable"],[]) "result") =?>
70− "<var>result</var>"
71− ]
72− , testGroup "sample with style"
73− [ "samp should wrap highlighted code" =:
74− codeWith ("",["sample","haskell"],[]) ">>="
75− =?> ("<samp><code class=\"sourceCode haskell\">" ++
76− "<span class=\"op\">&gt;&gt;=</span></code></samp>")
77− ]
78− , testGroup "variable with style"
79− [ "var should wrap highlighted code" =:
80− codeWith ("",["haskell","variable"],[]) ">>="
81− =?> ("<var><code class=\"sourceCode haskell\">" ++
82− "<span class=\"op\">&gt;&gt;=</span></code></var>")
83− ]
84− ]
85− where
86− tQ :: (ToString a, ToPandoc a)
87− => String -> (a, String) -> TestTree
88− tQ = test htmlQTags
37+tests =
38+ [ testGroup "inline code"
39+ [ "basic" =: code "@&" =?> "<code>@&amp;</code>"
40+ , "haskell" =: codeWith ("",["haskell"],[]) ">>="
41+ =?> "<code class=\"sourceCode haskell\"><span class=\"op\">&gt;&gt;=</span></code>"
42+ , "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>="
43+ =?> "<code class=\"nolanguage\">&gt;&gt;=</code>"
44+ ]
45+ , testGroup "images"
46+ [ "alt with formatting" =:
47+ image "/url" "title" ("my " <> emph "image")
48+ =?> "<img src=\"/url\" title=\"title\" alt=\"my image\" />"
49+ ]
50+ , testGroup "blocks"
51+ [ "definition list with empty <dt>" =:
52+ definitionList [(mempty, [para $ text "foo bar"])]
53+ =?> "<dl><dt></dt><dd><p>foo bar</p></dd></dl>"
54+ , "heading with disallowed attributes" =:
55+ headerWith ("", [], [("invalid","1"), ("lang", "en")]) 1 "test"
56+ =?>
57+ "<h1 lang=\"en\">test</h1>"
58+ ]
59+ , testGroup "quotes"
60+ [ "quote with cite attribute (without q-tags)" =:
61+ doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))
62+ =?> "“<span cite=\"http://example.org\">examples</span>”"
63+ , tQ "quote with cite attribute (with q-tags)" $
64+ doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples"))
65+ =?> "<q cite=\"http://example.org\">examples</q>"
66+ ]
67+ , testGroup "sample"
68+ [ "sample should be rendered correctly" =:
69+ plain (codeWith ("",["sample"],[]) "Answer is 42") =?>
70+ "<samp>Answer is 42</samp>"
71+ ]
72+ , testGroup "variable"
73+ [ "variable should be rendered correctly" =:
74+ plain (codeWith ("",["variable"],[]) "result") =?>
75+ "<var>result</var>"
76+ ]
77+ , testGroup "sample with style"
78+ [ "samp should wrap highlighted code" =:
79+ codeWith ("",["sample","haskell"],[]) ">>="
80+ =?> ("<samp><code class=\"sourceCode haskell\">" ++
81+ "<span class=\"op\">&gt;&gt;=</span></code></samp>")
82+ ]
83+ , testGroup "variable with style"
84+ [ "var should wrap highlighted code" =:
85+ codeWith ("",["haskell","variable"],[]) ">>="
86+ =?> ("<var><code class=\"sourceCode haskell\">" ++
87+ "<span class=\"op\">&gt;&gt;=</span></code></var>")
88+ ]
89+ ]
90+ where
91+ tQ :: (ToString a, ToPandoc a)
92+ => String -> (a, String) -> TestTree
93+ tQ = test htmlQTags