038261e · typeable/pandoc

git.iko.soy/typeable/pandoc

JATS writer: escape disallows chars in identifiers

XML identifiers must start with an underscore or letter, and can contain only a limited set of punctuation characters. Any IDs not adhering to these rules are rewritten by writing the offending characters as Uxxxx, where `xxxx` is the character's hex code.

commit038261ea529bc4516d7cee501db70020938dbf2b authorAlbert Krewinkel <albert@zeitkraut.de> dateMon 5 Apr 2021, 21:45 (6 years ago) parent65a9d3a

5 files changed+162−109

compare with master

unifiedsplit

src/Text/Pandoc/Writers/JATS.hs+14−13 src/Text/Pandoc/Writers/JATS/References.hs+3−2 src/Text/Pandoc/Writers/JATS/Table.hs+2−2 src/Text/Pandoc/XML.hs+28−2 test/Tests/Writers/JATS.hs+115−90

src/Text/Pandoc/Writers/JATS.hs+14−13

@@ -239,7 +239,7 @@ languageFor classes =

239239codeAttr :: Attr -> (Text, [(Text, Text)])

240240codeAttr (ident,classes,kvs) = (lang, attr)

241241 where

242− attr = [("id",ident) | not (T.null ident)] ++

242+ attr = [("id", escapeNCName ident) | not (T.null ident)] ++

243243 [("language",lang) | not (T.null lang)] ++

244244 [(k,v) | (k,v) <- kvs, k `elem` ["code-type",

245245 "code-version", "executable",

@@ -251,7 +251,8 @@ codeAttr (ident,classes,kvs) = (lang, attr)

251251blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m (Doc Text)

252252blockToJATS _ Null = return empty

253253blockToJATS opts (Div (id',"section":_,kvs) (Header _lvl _ ils : xs)) = do

254− let idAttr = [("id", writerIdentifierPrefix opts <> id') | not (T.null id')]

254+ let idAttr = [ ("id", writerIdentifierPrefix opts <> escapeNCName id')

255+ | not (T.null id')]

255256 let otherAttrs = ["sec-type", "specific-use"]

256257 let attribs = idAttr ++ [(k,v) | (k,v) <- kvs, k `elem` otherAttrs]

257258 title' <- inlinesToJATS opts ils

@@ -260,7 +261,7 @@ blockToJATS opts (Div (id',"section":_,kvs) (Header _lvl _ ils : xs)) = do

260261 inTagsSimple "title" title' $$ contents

261262-- Bibliography reference:

262263blockToJATS opts (Div (ident,_,_) [Para lst]) | "ref-" `T.isPrefixOf` ident =

263− inTags True "ref" [("id", ident)] .

264+ inTags True "ref" [("id", escapeNCName ident)] .

264265 inTagsSimple "mixed-citation" <$>

265266 inlinesToJATS opts lst

266267blockToJATS opts (Div ("refs",_,_) xs) = do

@@ -271,14 +272,14 @@ blockToJATS opts (Div ("refs",_,_) xs) = do

271272 return $ inTagsIndented "ref-list" contents

272273blockToJATS opts (Div (ident,[cls],kvs) bs) | cls `elem` ["fig", "caption", "table-wrap"] = do

273274 contents <- blocksToJATS opts bs

274− let attr = [("id", ident) | not (T.null ident)] ++

275+ let attr = [("id", escapeNCName ident) | not (T.null ident)] ++

275276 [("xml:lang",l) | ("lang",l) <- kvs] ++

276277 [(k,v) | (k,v) <- kvs, k `elem` ["specific-use",

277278 "content-type", "orientation", "position"]]

278279 return $ inTags True cls attr contents

279280blockToJATS opts (Div (ident,_,kvs) bs) = do

280281 contents <- blocksToJATS opts bs

281− let attr = [("id", ident) | not (T.null ident)] ++

282+ let attr = [("id", escapeNCName ident) | not (T.null ident)] ++

282283 [("xml:lang",l) | ("lang",l) <- kvs] ++

283284 [(k,v) | (k,v) <- kvs, k `elem` ["specific-use",

284285 "content-type", "orientation", "position"]]

@@ -296,7 +297,7 @@ blockToJATS opts (Para [Image (ident,_,kvs) txt

296297 let capt = if null txt

297298 then empty

298299 else inTagsSimple "caption" $ inTagsSimple "p" alt

299− let attr = [("id", ident) | not (T.null ident)] ++

300+ let attr = [("id", escapeNCName ident) | not (T.null ident)] ++

300301 [(k,v) | (k,v) <- kvs, k `elem` ["fig-type", "orientation",

301302 "position", "specific-use"]]

302303 let graphicattr = [("mimetype",maintype),

@@ -307,7 +308,7 @@ blockToJATS opts (Para [Image (ident,_,kvs) txt

307308 capt $$ selfClosingTag "graphic" graphicattr

308309blockToJATS _ (Para [Image (ident,_,kvs) _ (src, tit)]) = do

309310 let (maintype, subtype) = imageMimeType src kvs

310− let attr = [("id", ident) | not (T.null ident)] ++

311+ let attr = [("id", escapeNCName ident) | not (T.null ident)] ++

311312 [("mimetype", maintype),

312313 ("mime-subtype", subtype),

313314 ("xlink:href", src)] ++

@@ -434,7 +435,7 @@ inlineToJATS opts (Note contents) = do

434435 let notenum = case notes of

435436 (n, _):_ -> n + 1

436437 [] -> 1

437− thenote <- inTags True "fn" [("id","fn" <> tshow notenum)]

438+ thenote <- inTags True "fn" [("id", "fn" <> tshow notenum)]

438439 <$> wrappedBlocksToJATS (not . isPara) opts

439440 (walk demoteHeaderAndRefs contents)

440441 modify $ \st -> st{ jatsNotes = (notenum, thenote) : notes }

@@ -447,7 +448,7 @@ inlineToJATS opts (Cite _ lst) =

447448inlineToJATS opts (Span ("",_,[]) ils) = inlinesToJATS opts ils

448449inlineToJATS opts (Span (ident,_,kvs) ils) = do

449450 contents <- inlinesToJATS opts ils

450− let attr = [("id",ident) | not (T.null ident)] ++

451+ let attr = [("id", escapeNCName ident) | not (T.null ident)] ++

451452 [("xml:lang",l) | ("lang",l) <- kvs] ++

452453 [(k,v) | (k,v) <- kvs

453454 , k `elem` ["content-type", "rationale",

@@ -488,9 +489,9 @@ inlineToJATS _ (Link _attr [Str t] (T.stripPrefix "mailto:" -> Just email, _))

488489 return $ inTagsSimple "email" $ literal (escapeStringForXML email)

489490inlineToJATS opts (Link (ident,_,kvs) txt (T.uncons -> Just ('#', src), _)) = do

490491 let attr = mconcat

491− [ [("id", ident) | not (T.null ident)]

492+ [ [("id", escapeNCName ident) | not (T.null ident)]

492493 , [("alt", stringify txt) | not (null txt)]

493− , [("rid", src)]

494+ , [("rid", escapeNCName src)]

494495 , [(k,v) | (k,v) <- kvs, k `elem` ["ref-type", "specific-use"]]

495496 , [("ref-type", "bibr") | "ref-" `T.isPrefixOf` src]

496497 ]

@@ -500,7 +501,7 @@ inlineToJATS opts (Link (ident,_,kvs) txt (T.uncons -> Just ('#', src), _)) = do

500501 contents <- inlinesToJATS opts txt

501502 return $ inTags False "xref" attr contents

502503inlineToJATS opts (Link (ident,_,kvs) txt (src, tit)) = do

503− let attr = [("id", ident) | not (T.null ident)] ++

504+ let attr = [("id", escapeNCName ident) | not (T.null ident)] ++

504505 [("ext-link-type", "uri"),

505506 ("xlink:href", src)] ++

506507 [("xlink:title", tit) | not (T.null tit)] ++

@@ -518,7 +519,7 @@ inlineToJATS _ (Image (ident,_,kvs) _ (src, tit)) = do

518519 let subtype = fromMaybe "" $

519520 lookup "mime-subtype" kvs `mplus`

520521 (T.drop 1 . T.dropWhile (/='/') <$> mbMT)

521− let attr = [("id", ident) | not (T.null ident)] ++

522+ let attr = [("id", escapeNCName ident) | not (T.null ident)] ++

522523 [("mimetype", maintype),

523524 ("mime-subtype", subtype),

524525 ("xlink:href", src)] ++

src/Text/Pandoc/Writers/JATS/References.hs+3−2

@@ -29,7 +29,7 @@ import Text.Pandoc.Builder (Inlines)

2929import Text.Pandoc.Options (WriterOptions)

3030import Text.Pandoc.Shared (tshow)

3131import Text.Pandoc.Writers.JATS.Types

32−import Text.Pandoc.XML (escapeStringForXML, inTags)

32+import Text.Pandoc.XML (escapeNCName, escapeStringForXML, inTags)

3333import qualified Data.Text as T

3434

3535referencesToJATS :: PandocMonad m

@@ -46,7 +46,8 @@ referenceToJATS :: PandocMonad m

4646referenceToJATS _opts ref = do

4747 let refType = referenceType ref

4848 let pubType = [("publication-type", refType) | not (T.null refType)]

49− let wrap = inTags True "ref" [("id", "ref-" <> unItemId (referenceId ref))]

49+ let ident = escapeNCName $ "ref-" <> unItemId (referenceId ref)

50+ let wrap = inTags True "ref" [("id", ident)]

5051 . inTags True "element-citation" pubType

5152 return . wrap . vcat $

5253 [ authors

src/Text/Pandoc/Writers/JATS/Table.hs+2−2

@@ -24,7 +24,7 @@ import Text.Pandoc.Definition

2424import Text.Pandoc.Options (WriterOptions)

2525import Text.Pandoc.Shared (tshow)

2626import Text.Pandoc.Writers.JATS.Types

27−import Text.Pandoc.XML (inTags, inTagsIndented, selfClosingTag)

27+import Text.Pandoc.XML (escapeNCName, inTags, inTagsIndented, selfClosingTag)

2828import qualified Data.Text as T

2929import qualified Text.Pandoc.Writers.AnnotatedTable as Ann

3030

@@ -216,7 +216,7 @@ cellToJats opts celltype (Ann.Cell (colspec :| _) _colNum cell) =

216216

217217toAttribs :: Attr -> [Text] -> [(Text, Text)]

218218toAttribs (ident, _classes, kvs) knownAttribs =

219− (if T.null ident then id else (("id", ident) :)) $

219+ (if T.null ident then id else (("id", escapeNCName ident) :)) $

220220 filter ((`elem` knownAttribs) . fst) kvs

221221

222222tableCellToJats :: PandocMonad m

src/Text/Pandoc/XML.hs+28−2

@@ -13,6 +13,7 @@ Functions for escaping and formatting XML.

1313-}

1414module Text.Pandoc.XML ( escapeCharForXML,

1515 escapeStringForXML,

16+ escapeNCName,

1617 inTags,

1718 selfClosingTag,

1819 inTagsSimple,

@@ -24,7 +25,7 @@ module Text.Pandoc.XML ( escapeCharForXML,

2425 html5Attributes,

2526 rdfaAttributes ) where

2627

27−import Data.Char (isAscii, isSpace, ord)

28+import Data.Char (isAscii, isSpace, ord, isLetter, isDigit)

2829import Data.Text (Text)

2930import qualified Data.Text as T

3031import Text.HTML.TagSoup.Entity (lookupEntity, htmlEntities)

@@ -119,8 +120,33 @@ html5EntityMap = foldr go mempty htmlEntities

119120 where ent' = T.takeWhile (/=';') (T.pack ent)

120121 _ -> entmap

121122

123+-- | Converts a string into an NCName, i.e., an XML name without colons.

124+-- Disallowed characters are escaped using @ux%x@, where @%x@ is the

125+-- hexadecimal unicode identifier of the escaped character.

126+escapeNCName :: Text -> Text

127+escapeNCName t = case T.uncons t of

128+ Nothing -> T.empty

129+ Just (c, cs) -> escapeStartChar c <> T.concatMap escapeNCNameChar cs

130+ where

131+ escapeStartChar :: Char -> Text

132+ escapeStartChar c = if isLetter c || c == '_'

133+ then T.singleton c

134+ else escapeChar c

122135

123−-- Unescapes XML entities

136+ escapeNCNameChar :: Char -> Text

137+ escapeNCNameChar c = if isNCNameChar c

138+ then T.singleton c

139+ else escapeChar c

140+

141+ isNCNameChar :: Char -> Bool

142+ isNCNameChar c = isLetter c || c `elem` ("_-.·" :: String) || isDigit c

143+ || '\x0300' <= c && c <= '\x036f'

144+ || '\x203f' <= c && c <= '\x2040'

145+

146+ escapeChar :: Char -> Text

147+ escapeChar = T.pack . printf "U%04X" . ord

148+

149+-- | Unescapes XML entities

124150fromEntities :: Text -> Text

125151fromEntities t

126152 = let (x, y) = T.break (== '&') t

test/Tests/Writers/JATS.hs+115−90

@@ -1,21 +1,21 @@

11{-# LANGUAGE OverloadedStrings #-}

22module Tests.Writers.JATS (tests) where

4−import Data.Text (unpack)

4+import Data.Text (Text)

55import Test.Tasty

66import Tests.Helpers

77import Text.Pandoc

88import Text.Pandoc.Arbitrary ()

99import Text.Pandoc.Builder

10+import qualified Data.Text as T

1011

11−jats :: (ToPandoc a) => a -> String

12−jats = unpack

13− . purely (writeJATS def{ writerWrapText = WrapNone })

14− . toPandoc

12+jats :: (ToPandoc a) => a -> Text

13+jats = purely (writeJATS def{ writerWrapText = WrapNone })

14+ . toPandoc

1515

16−jatsArticleAuthoring :: (ToPandoc a) => a -> String

17−jatsArticleAuthoring = unpack

18− . purely (writeJatsArticleAuthoring def{ writerWrapText = WrapNone })

16+jatsArticleAuthoring :: (ToPandoc a) => a -> Text

17+jatsArticleAuthoring =

18+ purely (writeJatsArticleAuthoring def{ writerWrapText = WrapNone })

1919 . toPandoc

2020

2121{-

@@ -32,89 +32,114 @@ which is in turn shorthand for

3232

3333infix 4 =:

3434(=:) :: (ToString a, ToPandoc a)

35− => String -> (a, String) -> TestTree

35+ => String -> (a, Text) -> TestTree

3636(=:) = test jats

3737

3838tests :: [TestTree]

39−tests = [ testGroup "inline code"

40− [ "basic" =: code "@&" =?> "<monospace>@&</monospace>"

41− , "lang" =: codeWith ("", ["c"], []) "@&" =?> "<code language=\"c\">@&</code>"

42− ]

43− , testGroup "block code"

44− [ "basic" =: codeBlock "@&" =?> "<preformat>@&</preformat>"

45− , "lang" =: codeBlockWith ("", ["c"], []) "@&" =?> "<code language=\"c\">@&</code>"

46− ]

47− , testGroup "images"

48− [ "basic" =:

49− image "/url" "title" mempty

50− =?> "<graphic mimetype=\"image\" mime-subtype=\"\" xlink:href=\"/url\" xlink:title=\"title\" />"

51− ]

52− , testGroup "inlines"

53− [ "Emphasis" =: emph "emphasized"

54− =?> "<italic>emphasized</italic>"

39+tests =

40+ [ testGroup "inline code"

41+ [ "basic" =: code "@&" =?> "<monospace>@&</monospace>"

42+ , "lang" =: codeWith ("", ["c"], []) "@&" =?> "<code language=\"c\">@&</code>"

43+ ]

44+ , testGroup "block code"

45+ [ "basic" =: codeBlock "@&" =?> "<preformat>@&</preformat>"

46+ , "lang" =: codeBlockWith ("", ["c"], []) "@&" =?> "<code language=\"c\">@&</code>"

47+ ]

48+ , testGroup "images"

49+ [ "basic" =:

50+ image "/url" "title" mempty

51+ =?> "<graphic mimetype=\"image\" mime-subtype=\"\" xlink:href=\"/url\" xlink:title=\"title\" />"

52+ ]

53+ , testGroup "inlines"

54+ [ "Emphasis" =: emph "emphasized"

55+ =?> "<italic>emphasized</italic>"

56+

57+ , test jatsArticleAuthoring "footnote in articleauthoring tag set"

58+ ("test" <> note (para "footnote") =?>

59+ unlines [ "test<fn>"

60+ , " footnote"

61+ , "</fn>"

62+ ])

63+ ]

64+ , "bullet list" =: bulletList [ plain $ text "first"

65+ , plain $ text "second"

66+ , plain $ text "third"

67+ ]

68+ =?> "<list list-type=\"bullet\">\n\

69+ \ <list-item>\n\

70+ \ first\n\

71+ \ </list-item>\n\

72+ \ <list-item>\n\

73+ \ second\n\

74+ \ </list-item>\n\

75+ \ <list-item>\n\

76+ \ third\n\

77+ \ </list-item>\n\

78+ \</list>"

79+ , testGroup "definition lists"

80+ [ "with internal link" =: definitionList [(link "#go" "" (str "testing"),

81+ [plain (text "hi there")])] =?>

82+ "<def-list>\n\

83+ \ <def-item>\n\

84+ \ <term><xref alt=\"testing\" rid=\"go\">testing</xref></term>\n\

85+ \ <def>\n\

86+ \ hi there\n\

87+ \ </def>\n\

88+ \ </def-item>\n\

89+ \</def-list>"

90+ ]

91+ , testGroup "math"

92+ [ "escape |" =: para (math "\\sigma|_{\\{x\\}}") =?>

93+ "<inline-formula><alternatives>\n\

94+ \<tex-math><![CDATA[\\sigma|_{\\{x\\}}]]></tex-math>\n\

95+ \<mml:math display=\"inline\" xmlns:mml=\"http://www.w3.org/1998/Math/MathML\"><mml:mrow><mml:mi>σ</mml:mi><mml:msub><mml:mo stretchy=\"false\" form=\"prefix\">|</mml:mo><mml:mrow><mml:mo stretchy=\"false\" form=\"prefix\">{</mml:mo><mml:mi>x</mml:mi><mml:mo stretchy=\"false\" form=\"postfix\">}</mml:mo></mml:mrow></mml:msub></mml:mrow></mml:math></alternatives></inline-formula>"

96+ ]

97+ , testGroup "headers"

98+ [ "unnumbered header" =:

99+ headerWith ("foo",["unnumbered"],[]) 1

100+ (text "Header 1" <> note (plain $ text "note")) =?>

101+ "<sec id=\"foo\">\n\

102+ \ <title>Header 1<xref ref-type=\"fn\" rid=\"fn1\">1</xref></title>\n\

103+ \</sec>"

104+ , "unnumbered sub header" =:

105+ headerWith ("foo",["unnumbered"],[]) 1

106+ (text "Header")

107+ <> headerWith ("foo",["unnumbered"],[]) 2

108+ (text "Sub-Header") =?>

109+ "<sec id=\"foo\">\n\

110+ \ <title>Header</title>\n\

111+ \ <sec id=\"foo\">\n\

112+ \ <title>Sub-Header</title>\n\

113+ \ </sec>\n\

114+ \</sec>"

115+ , "containing image" =:

116+ header 1 (image "imgs/foo.jpg" "" (text "Alt text")) =?>

117+ "<sec>\n\

118+ \ <title><inline-graphic mimetype=\"image\" mime-subtype=\"jpeg\" xlink:href=\"imgs/foo.jpg\" /></title>\n\

119+ \</sec>"

120+ ]

121+

122+ , testGroup "ids"

123+ [ "non-ASCII in header ID" =:

124+ headerWith ("smørbrød",[],[]) 1 (text "smørbrød") =?>

125+ T.unlines [ "<sec id=\"smørbrød\">"

126+ , " <title>smørbrød</title>"

127+ , "</sec>"

128+ ]

129+

130+ , "disallowed symbol in header id" =:

131+ headerWith ("i/o",[],[]) 1 (text "I/O") =?>

132+ T.unlines [ "<sec id=\"iU002Fo\">"

133+ , " <title>I/O</title>"

134+ , "</sec>"

135+ ]

136+

137+ , "disallowed symbols in internal link target" =:

138+ link "#foo:bar" "" "baz" =?>

139+ "<xref alt=\"baz\" rid=\"fooU003Abar\">baz</xref>"

55140

56− , test jatsArticleAuthoring "footnote in articleauthoring tag set"

57− ("test" <> note (para "footnote") =?>

58− unlines [ "test<fn>"

59− , " footnote"

60− , "</fn>"

61− ])

62− ]

63− , "bullet list" =: bulletList [ plain $ text "first"

64− , plain $ text "second"

65− , plain $ text "third"

66− ]

67− =?> "<list list-type=\"bullet\">\n\

68− \ <list-item>\n\

69− \ first\n\

70− \ </list-item>\n\

71− \ <list-item>\n\

72− \ second\n\

73− \ </list-item>\n\

74− \ <list-item>\n\

75− \ third\n\

76− \ </list-item>\n\

77− \</list>"

78− , testGroup "definition lists"

79− [ "with internal link" =: definitionList [(link "#go" "" (str "testing"),

80− [plain (text "hi there")])] =?>

81− "<def-list>\n\

82− \ <def-item>\n\

83− \ <term><xref alt=\"testing\" rid=\"go\">testing</xref></term>\n\

84− \ <def>\n\

85− \ hi there\n\

86− \ </def>\n\

87− \ </def-item>\n\

88− \</def-list>"

89− ]

90− , testGroup "math"

91− [ "escape |" =: para (math "\\sigma|_{\\{x\\}}") =?>

92− "<inline-formula><alternatives>\n\

93− \<tex-math><![CDATA[\\sigma|_{\\{x\\}}]]></tex-math>\n\

94− \<mml:math display=\"inline\" xmlns:mml=\"http://www.w3.org/1998/Math/MathML\"><mml:mrow><mml:mi>σ</mml:mi><mml:msub><mml:mo stretchy=\"false\" form=\"prefix\">|</mml:mo><mml:mrow><mml:mo stretchy=\"false\" form=\"prefix\">{</mml:mo><mml:mi>x</mml:mi><mml:mo stretchy=\"false\" form=\"postfix\">}</mml:mo></mml:mrow></mml:msub></mml:mrow></mml:math></alternatives></inline-formula>"

95− ]

96− , testGroup "headers"

97− [ "unnumbered header" =:

98− headerWith ("foo",["unnumbered"],[]) 1

99− (text "Header 1" <> note (plain $ text "note")) =?>

100− "<sec id=\"foo\">\n\

101− \ <title>Header 1<xref ref-type=\"fn\" rid=\"fn1\">1</xref></title>\n\

102− \</sec>"

103− , "unnumbered sub header" =:

104− headerWith ("foo",["unnumbered"],[]) 1

105− (text "Header")

106− <> headerWith ("foo",["unnumbered"],[]) 2

107− (text "Sub-Header") =?>

108− "<sec id=\"foo\">\n\

109− \ <title>Header</title>\n\

110− \ <sec id=\"foo\">\n\

111− \ <title>Sub-Header</title>\n\

112− \ </sec>\n\

113− \</sec>"

114− , "containing image" =:

115− header 1 (image "imgs/foo.jpg" "" (text "Alt text")) =?>

116− "<sec>\n\

117− \ <title><inline-graphic mimetype=\"image\" mime-subtype=\"jpeg\" xlink:href=\"imgs/foo.jpg\" /></title>\n\

118− \</sec>"

119− ]

120− ]

141+ , "code id starting with a number" =:

142+ codeWith ("7y",[],[]) "print 5" =?>

143+ "<monospace id=\"U0037y\">print 5</monospace>"

144+ ]

145+ ]