From 25f5b927773eb730c2d5ef834bd61e1d2d5f09df Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Mon, 17 May 2021 15:37:25 +0200
Subject: HTML writer: ensure headings only have valid attribs in HTML4

Fixes: #5944
---
 src/Text/Pandoc/Writers/HTML.hs |  16 +++++-
 test/Tests/Writers/HTML.hs      | 109 +++++++++++++++++++++-------------------
 2 files changed, 71 insertions(+), 54 deletions(-)

diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index 332de1545..f7a387927 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -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
diff --git a/test/Tests/Writers/HTML.hs b/test/Tests/Writers/HTML.hs
index 328801e31..404f6da98 100644
--- a/test/Tests/Writers/HTML.hs
+++ b/test/Tests/Writers/HTML.hs
@@ -34,55 +34,60 @@ infix 4 =:
 (=:) = test html
 
 tests :: [TestTree]
-tests = [ testGroup "inline code"
-          [ "basic" =: code "@&" =?> "<code>@&amp;</code>"
-          , "haskell" =: codeWith ("",["haskell"],[]) ">>="
-            =?> "<code class=\"sourceCode haskell\"><span class=\"op\">&gt;&gt;=</span></code>"
-          , "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>="
-            =?> "<code class=\"nolanguage\">&gt;&gt;=</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\">&gt;&gt;=</span></code></samp>")
-          ]
-        , testGroup "variable with style"
-          [ "var should wrap highlighted code" =:
-            codeWith ("",["haskell","variable"],[]) ">>="
-            =?> ("<var><code class=\"sourceCode haskell\">" ++
-                "<span class=\"op\">&gt;&gt;=</span></code></var>")
-          ]
-        ]
-        where
-          tQ :: (ToString a, ToPandoc a)
-               => String -> (a, String) -> TestTree
-          tQ = test htmlQTags
+tests =
+  [ testGroup "inline code"
+    [ "basic" =: code "@&" =?> "<code>@&amp;</code>"
+    , "haskell" =: codeWith ("",["haskell"],[]) ">>="
+      =?> "<code class=\"sourceCode haskell\"><span class=\"op\">&gt;&gt;=</span></code>"
+    , "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>="
+      =?> "<code class=\"nolanguage\">&gt;&gt;=</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\">&gt;&gt;=</span></code></samp>")
+    ]
+  , testGroup "variable with style"
+    [ "var should wrap highlighted code" =:
+      codeWith ("",["haskell","variable"],[]) ">>="
+      =?> ("<var><code class=\"sourceCode haskell\">" ++
+          "<span class=\"op\">&gt;&gt;=</span></code></var>")
+    ]
+  ]
+  where
+    tQ :: (ToString a, ToPandoc a)
+         => String -> (a, String) -> TestTree
+    tQ = test htmlQTags
-- 
cgit v1.2.3