From 038261ea529bc4516d7cee501db70020938dbf2b Mon Sep 17 00:00:00 2001 From: Albert Krewinkel Date: Mon, 5 Apr 2021 21:45:52 +0200 Subject: 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. --- src/Text/Pandoc/Writers/JATS.hs | 27 ++-- src/Text/Pandoc/Writers/JATS/References.hs | 5 +- src/Text/Pandoc/Writers/JATS/Table.hs | 4 +- src/Text/Pandoc/XML.hs | 30 ++++- test/Tests/Writers/JATS.hs | 205 ++++++++++++++++------------- 5 files changed, 162 insertions(+), 109 deletions(-) diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs index a9369db7a..26f94cb03 100644 --- a/src/Text/Pandoc/Writers/JATS.hs +++ b/src/Text/Pandoc/Writers/JATS.hs @@ -239,7 +239,7 @@ languageFor classes = codeAttr :: Attr -> (Text, [(Text, Text)]) codeAttr (ident,classes,kvs) = (lang, attr) where - attr = [("id",ident) | not (T.null ident)] ++ + attr = [("id", escapeNCName ident) | not (T.null ident)] ++ [("language",lang) | not (T.null lang)] ++ [(k,v) | (k,v) <- kvs, k `elem` ["code-type", "code-version", "executable", @@ -251,7 +251,8 @@ codeAttr (ident,classes,kvs) = (lang, attr) blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m (Doc Text) blockToJATS _ Null = return empty blockToJATS opts (Div (id',"section":_,kvs) (Header _lvl _ ils : xs)) = do - let idAttr = [("id", writerIdentifierPrefix opts <> id') | not (T.null id')] + let idAttr = [ ("id", writerIdentifierPrefix opts <> escapeNCName id') + | not (T.null id')] let otherAttrs = ["sec-type", "specific-use"] let attribs = idAttr ++ [(k,v) | (k,v) <- kvs, k `elem` otherAttrs] title' <- inlinesToJATS opts ils @@ -260,7 +261,7 @@ blockToJATS opts (Div (id',"section":_,kvs) (Header _lvl _ ils : xs)) = do inTagsSimple "title" title' $$ contents -- Bibliography reference: blockToJATS opts (Div (ident,_,_) [Para lst]) | "ref-" `T.isPrefixOf` ident = - inTags True "ref" [("id", ident)] . + inTags True "ref" [("id", escapeNCName ident)] . inTagsSimple "mixed-citation" <$> inlinesToJATS opts lst blockToJATS opts (Div ("refs",_,_) xs) = do @@ -271,14 +272,14 @@ blockToJATS opts (Div ("refs",_,_) xs) = do return $ inTagsIndented "ref-list" contents blockToJATS opts (Div (ident,[cls],kvs) bs) | cls `elem` ["fig", "caption", "table-wrap"] = do contents <- blocksToJATS opts bs - let attr = [("id", ident) | not (T.null ident)] ++ + let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ [("xml:lang",l) | ("lang",l) <- kvs] ++ [(k,v) | (k,v) <- kvs, k `elem` ["specific-use", "content-type", "orientation", "position"]] return $ inTags True cls attr contents blockToJATS opts (Div (ident,_,kvs) bs) = do contents <- blocksToJATS opts bs - let attr = [("id", ident) | not (T.null ident)] ++ + let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ [("xml:lang",l) | ("lang",l) <- kvs] ++ [(k,v) | (k,v) <- kvs, k `elem` ["specific-use", "content-type", "orientation", "position"]] @@ -296,7 +297,7 @@ blockToJATS opts (Para [Image (ident,_,kvs) txt let capt = if null txt then empty else inTagsSimple "caption" $ inTagsSimple "p" alt - let attr = [("id", ident) | not (T.null ident)] ++ + let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ [(k,v) | (k,v) <- kvs, k `elem` ["fig-type", "orientation", "position", "specific-use"]] let graphicattr = [("mimetype",maintype), @@ -307,7 +308,7 @@ blockToJATS opts (Para [Image (ident,_,kvs) txt capt $$ selfClosingTag "graphic" graphicattr blockToJATS _ (Para [Image (ident,_,kvs) _ (src, tit)]) = do let (maintype, subtype) = imageMimeType src kvs - let attr = [("id", ident) | not (T.null ident)] ++ + let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ [("mimetype", maintype), ("mime-subtype", subtype), ("xlink:href", src)] ++ @@ -434,7 +435,7 @@ inlineToJATS opts (Note contents) = do let notenum = case notes of (n, _):_ -> n + 1 [] -> 1 - thenote <- inTags True "fn" [("id","fn" <> tshow notenum)] + thenote <- inTags True "fn" [("id", "fn" <> tshow notenum)] <$> wrappedBlocksToJATS (not . isPara) opts (walk demoteHeaderAndRefs contents) modify $ \st -> st{ jatsNotes = (notenum, thenote) : notes } @@ -447,7 +448,7 @@ inlineToJATS opts (Cite _ lst) = inlineToJATS opts (Span ("",_,[]) ils) = inlinesToJATS opts ils inlineToJATS opts (Span (ident,_,kvs) ils) = do contents <- inlinesToJATS opts ils - let attr = [("id",ident) | not (T.null ident)] ++ + let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ [("xml:lang",l) | ("lang",l) <- kvs] ++ [(k,v) | (k,v) <- kvs , k `elem` ["content-type", "rationale", @@ -488,9 +489,9 @@ inlineToJATS _ (Link _attr [Str t] (T.stripPrefix "mailto:" -> Just email, _)) return $ inTagsSimple "email" $ literal (escapeStringForXML email) inlineToJATS opts (Link (ident,_,kvs) txt (T.uncons -> Just ('#', src), _)) = do let attr = mconcat - [ [("id", ident) | not (T.null ident)] + [ [("id", escapeNCName ident) | not (T.null ident)] , [("alt", stringify txt) | not (null txt)] - , [("rid", src)] + , [("rid", escapeNCName src)] , [(k,v) | (k,v) <- kvs, k `elem` ["ref-type", "specific-use"]] , [("ref-type", "bibr") | "ref-" `T.isPrefixOf` src] ] @@ -500,7 +501,7 @@ inlineToJATS opts (Link (ident,_,kvs) txt (T.uncons -> Just ('#', src), _)) = do contents <- inlinesToJATS opts txt return $ inTags False "xref" attr contents inlineToJATS opts (Link (ident,_,kvs) txt (src, tit)) = do - let attr = [("id", ident) | not (T.null ident)] ++ + let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ [("ext-link-type", "uri"), ("xlink:href", src)] ++ [("xlink:title", tit) | not (T.null tit)] ++ @@ -518,7 +519,7 @@ inlineToJATS _ (Image (ident,_,kvs) _ (src, tit)) = do let subtype = fromMaybe "" $ lookup "mime-subtype" kvs `mplus` (T.drop 1 . T.dropWhile (/='/') <$> mbMT) - let attr = [("id", ident) | not (T.null ident)] ++ + let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ [("mimetype", maintype), ("mime-subtype", subtype), ("xlink:href", src)] ++ diff --git a/src/Text/Pandoc/Writers/JATS/References.hs b/src/Text/Pandoc/Writers/JATS/References.hs index 903144128..5b19fd034 100644 --- a/src/Text/Pandoc/Writers/JATS/References.hs +++ b/src/Text/Pandoc/Writers/JATS/References.hs @@ -29,7 +29,7 @@ import Text.Pandoc.Builder (Inlines) import Text.Pandoc.Options (WriterOptions) import Text.Pandoc.Shared (tshow) import Text.Pandoc.Writers.JATS.Types -import Text.Pandoc.XML (escapeStringForXML, inTags) +import Text.Pandoc.XML (escapeNCName, escapeStringForXML, inTags) import qualified Data.Text as T referencesToJATS :: PandocMonad m @@ -46,7 +46,8 @@ referenceToJATS :: PandocMonad m referenceToJATS _opts ref = do let refType = referenceType ref let pubType = [("publication-type", refType) | not (T.null refType)] - let wrap = inTags True "ref" [("id", "ref-" <> unItemId (referenceId ref))] + let ident = escapeNCName $ "ref-" <> unItemId (referenceId ref) + let wrap = inTags True "ref" [("id", ident)] . inTags True "element-citation" pubType return . wrap . vcat $ [ authors diff --git a/src/Text/Pandoc/Writers/JATS/Table.hs b/src/Text/Pandoc/Writers/JATS/Table.hs index 465480f59..2e34900d2 100644 --- a/src/Text/Pandoc/Writers/JATS/Table.hs +++ b/src/Text/Pandoc/Writers/JATS/Table.hs @@ -24,7 +24,7 @@ import Text.Pandoc.Definition import Text.Pandoc.Options (WriterOptions) import Text.Pandoc.Shared (tshow) import Text.Pandoc.Writers.JATS.Types -import Text.Pandoc.XML (inTags, inTagsIndented, selfClosingTag) +import Text.Pandoc.XML (escapeNCName, inTags, inTagsIndented, selfClosingTag) import qualified Data.Text as T import qualified Text.Pandoc.Writers.AnnotatedTable as Ann @@ -216,7 +216,7 @@ cellToJats opts celltype (Ann.Cell (colspec :| _) _colNum cell) = toAttribs :: Attr -> [Text] -> [(Text, Text)] toAttribs (ident, _classes, kvs) knownAttribs = - (if T.null ident then id else (("id", ident) :)) $ + (if T.null ident then id else (("id", escapeNCName ident) :)) $ filter ((`elem` knownAttribs) . fst) kvs tableCellToJats :: PandocMonad m diff --git a/src/Text/Pandoc/XML.hs b/src/Text/Pandoc/XML.hs index 6dbbce1d2..79b4768ec 100644 --- a/src/Text/Pandoc/XML.hs +++ b/src/Text/Pandoc/XML.hs @@ -13,6 +13,7 @@ Functions for escaping and formatting XML. -} module Text.Pandoc.XML ( escapeCharForXML, escapeStringForXML, + escapeNCName, inTags, selfClosingTag, inTagsSimple, @@ -24,7 +25,7 @@ module Text.Pandoc.XML ( escapeCharForXML, html5Attributes, rdfaAttributes ) where -import Data.Char (isAscii, isSpace, ord) +import Data.Char (isAscii, isSpace, ord, isLetter, isDigit) import Data.Text (Text) import qualified Data.Text as T import Text.HTML.TagSoup.Entity (lookupEntity, htmlEntities) @@ -119,8 +120,33 @@ html5EntityMap = foldr go mempty htmlEntities where ent' = T.takeWhile (/=';') (T.pack ent) _ -> entmap +-- | Converts a string into an NCName, i.e., an XML name without colons. +-- Disallowed characters are escaped using @ux%x@, where @%x@ is the +-- hexadecimal unicode identifier of the escaped character. +escapeNCName :: Text -> Text +escapeNCName t = case T.uncons t of + Nothing -> T.empty + Just (c, cs) -> escapeStartChar c <> T.concatMap escapeNCNameChar cs + where + escapeStartChar :: Char -> Text + escapeStartChar c = if isLetter c || c == '_' + then T.singleton c + else escapeChar c --- Unescapes XML entities + escapeNCNameChar :: Char -> Text + escapeNCNameChar c = if isNCNameChar c + then T.singleton c + else escapeChar c + + isNCNameChar :: Char -> Bool + isNCNameChar c = isLetter c || c `elem` ("_-.·" :: String) || isDigit c + || '\x0300' <= c && c <= '\x036f' + || '\x203f' <= c && c <= '\x2040' + + escapeChar :: Char -> Text + escapeChar = T.pack . printf "U%04X" . ord + +-- | Unescapes XML entities fromEntities :: Text -> Text fromEntities t = let (x, y) = T.break (== '&') t diff --git a/test/Tests/Writers/JATS.hs b/test/Tests/Writers/JATS.hs index 2f501c890..23c1686dc 100644 --- a/test/Tests/Writers/JATS.hs +++ b/test/Tests/Writers/JATS.hs @@ -1,21 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.JATS (tests) where -import Data.Text (unpack) +import Data.Text (Text) import Test.Tasty import Tests.Helpers import Text.Pandoc import Text.Pandoc.Arbitrary () import Text.Pandoc.Builder +import qualified Data.Text as T -jats :: (ToPandoc a) => a -> String -jats = unpack - . purely (writeJATS def{ writerWrapText = WrapNone }) - . toPandoc +jats :: (ToPandoc a) => a -> Text +jats = purely (writeJATS def{ writerWrapText = WrapNone }) + . toPandoc -jatsArticleAuthoring :: (ToPandoc a) => a -> String -jatsArticleAuthoring = unpack - . purely (writeJatsArticleAuthoring def{ writerWrapText = WrapNone }) +jatsArticleAuthoring :: (ToPandoc a) => a -> Text +jatsArticleAuthoring = + purely (writeJatsArticleAuthoring def{ writerWrapText = WrapNone }) . toPandoc {- @@ -32,89 +32,114 @@ which is in turn shorthand for infix 4 =: (=:) :: (ToString a, ToPandoc a) - => String -> (a, String) -> TestTree + => String -> (a, Text) -> TestTree (=:) = test jats tests :: [TestTree] -tests = [ testGroup "inline code" - [ "basic" =: code "@&" =?> "

@&

" - , "lang" =: codeWith ("", ["c"], []) "@&" =?> "

@&

" - ] - , testGroup "block code" - [ "basic" =: codeBlock "@&" =?> "@&" - , "lang" =: codeBlockWith ("", ["c"], []) "@&" =?> "@&" - ] - , testGroup "images" - [ "basic" =: - image "/url" "title" mempty - =?> "" - ] - , testGroup "inlines" - [ "Emphasis" =: emph "emphasized" - =?> "

emphasized

" +tests = + [ testGroup "inline code" + [ "basic" =: code "@&" =?> "

@&

" + , "lang" =: codeWith ("", ["c"], []) "@&" =?> "

@&

" + ] + , testGroup "block code" + [ "basic" =: codeBlock "@&" =?> "@&" + , "lang" =: codeBlockWith ("", ["c"], []) "@&" =?> "@&" + ] + , testGroup "images" + [ "basic" =: + image "/url" "title" mempty + =?> "" + ] + , testGroup "inlines" + [ "Emphasis" =: emph "emphasized" + =?> "

emphasized

" + + , test jatsArticleAuthoring "footnote in articleauthoring tag set" + ("test" <> note (para "footnote") =?> + unlines [ "

test" + , "

footnote

" + , "

" + ]) + ] + , "bullet list" =: bulletList [ plain $ text "first" + , plain $ text "second" + , plain $ text "third" + ] + =?> "\n\ + \ \n\ + \

first

\n\ + \ \n\ + \ \n\ + \

second

\n\ + \ \n\ + \ \n\ + \

third

\n\ + \ \n\ + \" + , testGroup "definition lists" + [ "with internal link" =: definitionList [(link "#go" "" (str "testing"), + [plain (text "hi there")])] =?> + "\n\ + \ \n\ + \ testing\n\ + \ \n\ + \

hi there

\n\ + \ \n\ + \ \n\ + \" + ] + , testGroup "math" + [ "escape |" =: para (math "\\sigma|_{\\{x\\}}") =?> + "

\n\ + \\n\ + \σ|{x}

" + ] + , testGroup "headers" + [ "unnumbered header" =: + headerWith ("foo",["unnumbered"],[]) 1 + (text "Header 1" <> note (plain $ text "note")) =?> + "\n\ + \ Header 1<xref ref-type=\"fn\" rid=\"fn1\">1</xref>\n\ + \" + , "unnumbered sub header" =: + headerWith ("foo",["unnumbered"],[]) 1 + (text "Header") + <> headerWith ("foo",["unnumbered"],[]) 2 + (text "Sub-Header") =?> + "\n\ + \ Header\n\ + \ \n\ + \ Sub-Header\n\ + \ \n\ + \" + , "containing image" =: + header 1 (image "imgs/foo.jpg" "" (text "Alt text")) =?> + "\n\ + \ <inline-graphic mimetype=\"image\" mime-subtype=\"jpeg\" xlink:href=\"imgs/foo.jpg\" />\n\ + \" + ] + + , testGroup "ids" + [ "non-ASCII in header ID" =: + headerWith ("smørbrød",[],[]) 1 (text "smørbrød") =?> + T.unlines [ "" + , " smørbrød" + , "" + ] + + , "disallowed symbol in header id" =: + headerWith ("i/o",[],[]) 1 (text "I/O") =?> + T.unlines [ "" + , " I/O" + , "" + ] + + , "disallowed symbols in internal link target" =: + link "#foo:bar" "" "baz" =?> + "

baz

" - , test jatsArticleAuthoring "footnote in articleauthoring tag set" - ("test" <> note (para "footnote") =?> - unlines [ "

test" - , "

footnote

" - , "

" - ]) - ] - , "bullet list" =: bulletList [ plain $ text "first" - , plain $ text "second" - , plain $ text "third" - ] - =?> "\n\ - \ \n\ - \

first

\n\ - \ \n\ - \ \n\ - \

second

\n\ - \ \n\ - \ \n\ - \

third

\n\ - \ \n\ - \" - , testGroup "definition lists" - [ "with internal link" =: definitionList [(link "#go" "" (str "testing"), - [plain (text "hi there")])] =?> - "\n\ - \ \n\ - \ testing\n\ - \ \n\ - \

hi there

\n\ - \ \n\ - \ \n\ - \" - ] - , testGroup "math" - [ "escape |" =: para (math "\\sigma|_{\\{x\\}}") =?> - "

\n\ - \\n\ - \σ|{x}

" - ] - , testGroup "headers" - [ "unnumbered header" =: - headerWith ("foo",["unnumbered"],[]) 1 - (text "Header 1" <> note (plain $ text "note")) =?> - "\n\ - \ Header 1<xref ref-type=\"fn\" rid=\"fn1\">1</xref>\n\ - \" - , "unnumbered sub header" =: - headerWith ("foo",["unnumbered"],[]) 1 - (text "Header") - <> headerWith ("foo",["unnumbered"],[]) 2 - (text "Sub-Header") =?> - "\n\ - \ Header\n\ - \ \n\ - \ Sub-Header\n\ - \ \n\ - \" - , "containing image" =: - header 1 (image "imgs/foo.jpg" "" (text "Alt text")) =?> - "\n\ - \ <inline-graphic mimetype=\"image\" mime-subtype=\"jpeg\" xlink:href=\"imgs/foo.jpg\" />\n\ - \" - ] - ] + , "code id starting with a number" =: + codeWith ("7y",[],[]) "print 5" =?> + "

print 5

" + ] + ] -- cgit v1.2.3