diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -1,5 +1,37 @@
# Changelog for commonmark
+
+## 0.3.0.1
+
+ * Add test for cmark#383 case that motivated f47801c.
+
+ * Add pathological tests from commonmark.js to the test suite.
+ Ports the 31 pathological cases from commonmark.js's test/test.js
+ (sizes 1000 and 10000) as a tasty test group with a 5-second
+ per-test timeout, so nonlinear parsing behavior shows up as a
+ test failure.
+
+ * Fix `stackBottoms` lookup key in `processEm`, restoring linear
+ behavior. (Regression since f47801c.)
+
+ * Track bracket balance incrementally in `processBs`. Avoids quadratic
+ performance in pathological cases.
+
+ * Replace U+0000 with U+FFFD in tokenize, in accordance with the
+ commonmark spec.
+
+ * Html: don't merge adjacent text nodes in (<>); fixes quadratic rendering.
+
+ * Disallow ASCII control characters in link destinations, per the
+ commonmark spec.
+
+ * Speed up `escapeURI`.
+
+ * Prune `backtickSpans` state when no closer is found. Avoids
+ quadratic performance in pathological cases.
+
+ * Autolink: implement GFM preceding-character restriction.
+
## 0.3
* Applicative instances of IsBlock, IsInline etc. (Ashley Yakeley).
diff --git a/commonmark.cabal b/commonmark.cabal
--- a/commonmark.cabal
+++ b/commonmark.cabal
@@ -1,6 +1,6 @@
cabal-version: 2.2
name: commonmark
-version: 0.3
+version: 0.3.0.1
synopsis: Pure Haskell commonmark parser.
description:
This library provides the core data types and functions
@@ -40,9 +40,10 @@
license-file: LICENSE
build-type: Simple
-extra-source-files:
+extra-doc-files:
changelog.md
README.md
+extra-source-files:
test/spec.txt
test/regression.md
diff --git a/src/Commonmark/Blocks.hs b/src/Commonmark/Blocks.hs
--- a/src/Commonmark/Blocks.hs
+++ b/src/Commonmark/Blocks.hs
@@ -97,8 +97,8 @@
, nextAttributes = mempty
}
"source" (length ts `seq` ts)
- -- we evaluate length ts to make sure the list is
- -- fully evaluated; this helps performance. note that
+ -- we evaluate length ts to make sure the list spine is
+ -- evaluated; this helps performance. note that
-- we can't use deepseq because there's no instance for SourcePos.
processLines :: (Monad m, IsBlock il bl)
diff --git a/src/Commonmark/Html.hs b/src/Commonmark/Html.hs
--- a/src/Commonmark/Html.hs
+++ b/src/Commonmark/Html.hs
@@ -27,7 +27,6 @@
import Data.Text.Encoding (encodeUtf8)
import qualified Data.ByteString.Char8 as B
import qualified Data.Set as Set
-import Text.Printf (printf)
import Unicode.Char (ord, isAlphaNum, isAscii)
import Unicode.Char.General.Compat (isSpace)
import Data.Maybe (fromMaybe)
@@ -49,9 +48,14 @@
instance Semigroup (Html a) where
x <> HtmlNull = x
HtmlNull <> x = x
- HtmlText t1 <> HtmlText t2 = HtmlText (t1 <> t2)
- HtmlRaw t1 <> HtmlRaw t2 = HtmlRaw (t1 <> t2)
x <> y = HtmlConcat x y
+ -- Note: adjacent HtmlText (or HtmlRaw) nodes must NOT be merged
+ -- here with Text (<>): a paragraph is mconcat'ed from one node per
+ -- word, and pairwise Text appends would copy the growing text at
+ -- each step, making rendering quadratic in the paragraph size.
+ -- renderHtml goes through a Builder, and escapeHtml is
+ -- character-local, so keeping the nodes separate produces
+ -- identical output in linear time.
instance Monoid (Html a) where
mempty = HtmlNull
@@ -456,14 +460,24 @@
escapeHtmlChar c = singleton c
escapeURI :: Text -> Text
-escapeURI = mconcat . map escapeURIChar . B.unpack . encodeUtf8
+escapeURI t
+ | B.all isAllowedURIChar bs = t
+ | otherwise = TL.toStrict $ toLazyText $
+ B.foldr (\c b -> escapeURIChar c <> b) mempty bs
+ where bs = encodeUtf8 t
-escapeURIChar :: Char -> Text
+isAllowedURIChar :: Char -> Bool
+isAllowedURIChar c =
+ (isAscii c && isAlphaNum c) ||
+ c `elem` ("%/?:@-._~&#!$'()*+,;=" :: [Char])
+
+-- Note: c is a byte of the UTF-8 encoding, so ord c <= 255.
+escapeURIChar :: Char -> Builder
escapeURIChar c
- | isEscapable c = T.singleton '%' <> T.pack (printf "%02X" (ord c))
- | otherwise = T.singleton c
- where isEscapable d = not (isAscii d && isAlphaNum d)
- && d `notElem` ['%','/','?',':','@','-','.','_','~','&',
- '#','!','$','\'','(',')','*','+',',',
- ';','=']
+ | isAllowedURIChar c = singleton c
+ | otherwise = singleton '%' <> singleton (hexDig hi) <> singleton (hexDig lo)
+ where
+ (hi, lo) = ord c `divMod` 16
+ hexDig i | i < 10 = toEnum (i + fromEnum '0')
+ | otherwise = toEnum (i - 10 + fromEnum 'A')
diff --git a/src/Commonmark/Inlines.hs b/src/Commonmark/Inlines.hs
--- a/src/Commonmark/Inlines.hs
+++ b/src/Commonmark/Inlines.hs
@@ -13,6 +13,7 @@
, IPState
, InlineParser
, getReferenceMap
+ , getPrecedingTokType
, FormattingSpec(..)
, defaultFormattingSpecs
, BracketedSpec(..)
@@ -204,8 +205,13 @@
precedingTokTypeMap = {-# SCC precedingTokTypeMap #-}fst $! foldl' go (mempty, LineEnd) ts
go (!m, !prevTy) (Tok !ty !pos _) =
case ty of
- Symbol c | isDelimChar c -> (M.insert pos prevTy m, ty)
- _ -> (m, ty)
+ Symbol c | isDelimChar c -> (M.insert pos prevTy m, ty)
+ -- record word tokens preceded by a symbol, so that extensions
+ -- (e.g. autolinks) can check what precedes them; a word token
+ -- not in the map is preceded by whitespace or begins the input
+ -- (adjacent word characters are merged by the tokenizer):
+ WordChars | Symbol _ <- prevTy -> (M.insert pos prevTy m, ty)
+ _ -> (m, ty)
data Chunk a = Chunk
{ chunkType :: ChunkType a
@@ -484,6 +490,16 @@
getReferenceMap :: Monad m => InlineParser m ReferenceMap
getReferenceMap = ipReferenceMap <$> getState
+-- | Type of the token immediately preceding the current position,
+-- if recorded. Preceding token types are recorded for positions of
+-- delimiter characters, and for word tokens preceded by a symbol.
+-- 'Nothing' at the start of a word token means it begins the input
+-- or is preceded by whitespace.
+getPrecedingTokType :: Monad m => InlineParser m (Maybe TokType)
+getPrecedingTokType = do
+ pos <- getPosition
+ M.lookup pos . precedingTokTypes <$> getState
+
pBacktickSpan :: Monad m
=> Tok -> InlineParser m (Either [Tok] [Tok])
pBacktickSpan tok = do
@@ -498,7 +514,13 @@
updateState $ \st ->
st{ backtickSpans = IntMap.insert numticks ps (backtickSpans st) }
return $ Right codetoks
- _ -> return $ Left ts
+ Just [] -> do
+ -- no closer ahead: remove the exhausted entry so that later
+ -- spans of this length don't rescan the stale positions
+ updateState $ \st ->
+ st{ backtickSpans = IntMap.delete numticks (backtickSpans st) }
+ return $ Left ts
+ Nothing -> return $ Left ts
normalizeCodeSpan :: Text -> Text
normalizeCodeSpan = removeSurroundingSpace . T.map nltosp
@@ -566,6 +588,14 @@
, refmap :: ReferenceMap
, stackBottoms :: M.Map Text SourcePos
, absoluteBottom :: SourcePos
+ , middleBalance :: !Int
+ -- ^ Bracket balance of the chunks strictly between the two
+ -- cursors. Maintained incrementally by processBs (unused in
+ -- processEm) so that checking for balanced brackets is O(1)
+ -- instead of a scan over the chunks between the cursors.
+ , middleHasBracket :: !Bool
+ -- ^ Whether any chunk strictly between the two cursors is a
+ -- bracket delimiter. Maintained incrementally by processBs.
}
@@ -581,7 +611,9 @@
, rightCursor = startcursor
, refmap = emptyReferenceMap
, stackBottoms = mempty
- , absoluteBottom = chunkPos z }
+ , absoluteBottom = chunkPos z
+ , middleBalance = 0
+ , middleHasBracket = False }
{- for debugging:
prettyCursors :: (IsInline a) => Cursor (Chunk a) -> Cursor (Chunk a) -> String
@@ -673,7 +705,8 @@
}
| Just (chunkPos chunk) <=
- M.lookup (T.pack (c: show (length ts `mod` 3))) bottoms ->
+ M.lookup (T.pack ([c, if canopen then '1' else '0']
+ ++ show (length ts `mod` 3))) bottoms ->
processEm
st{ leftCursor = right
, rightCursor = moveRight right
@@ -709,9 +742,11 @@
bracketChunkToNumber (Chunk Delim{ delimType = '[' } _ _) = 1
bracketChunkToNumber (Chunk Delim{ delimType = ']' } _ _) = -1
bracketChunkToNumber _ = 0
-bracketMatchedCount :: [Chunk a] -> Int
-bracketMatchedCount chunksinside = sum $ map bracketChunkToNumber chunksinside
+isBracketChunk :: Chunk a -> Bool
+isBracketChunk (Chunk Delim{ delimType = c } _ _) = c == '[' || c == ']'
+isBracketChunk _ = False
+
-- | Process square brackets: links, images, and the span extension.
--
-- DState tracks the current position and backtracking limits.
@@ -743,6 +778,8 @@
, refmap = rm
, stackBottoms = bottoms
, absoluteBottom = chunkPos z
+ , middleBalance = 0
+ , middleHasBracket = False
}
data Cursor a = Cursor
@@ -787,6 +824,8 @@
st{ leftCursor = moveRight right
, rightCursor = moveRight right
, absoluteBottom = chunkPos chunk
+ , middleBalance = 0
+ , middleHasBracket = False
}
(Just chunk, Just chunk')
@@ -795,16 +834,15 @@
st { leftCursor = moveRight right
, rightCursor = moveRight right
, absoluteBottom = chunkPos chunk'
+ , middleBalance = 0
+ , middleHasBracket = False
}
(Just opener@(Chunk Delim{ delimType = '[' } _ _),
Just closer@(Chunk Delim{ delimType = ']'} closePos _)) ->
let chunksinside = takeWhile (\ch -> chunkPos ch /= closePos)
(afters left)
- isBracket (Chunk Delim{ delimType = c' } _ _) =
- c' == '[' || c' == ']'
- isBracket _ = False
- key = if any isBracket chunksinside
+ key = if middleHasBracket st
then ""
else
case untokenize (concatMap chunkToks chunksinside) of
@@ -827,7 +865,7 @@
suffixPos = incSourceColumn closePos 1
- in case (bracketMatchedCount chunksinside, parse
+ in case (middleBalance st, parse
(withRaw
(do setPosition suffixPos
(spec, constructor) <- choice $
@@ -840,7 +878,10 @@
processBs bracketedSpecs
st{ leftCursor = moveLeft (leftCursor st)
, rightCursor = fixSingleQuote $
- moveRight (rightCursor st) }
+ moveRight (rightCursor st)
+ -- the middle absorbs the opener and closer,
+ -- which cancel out (+1 - 1):
+ , middleHasBracket = True }
(0, Right ((spec, constructor, newpos), desttoks)) ->
let left' = case bracketedPrefix spec of
Just _ -> moveLeft left
@@ -880,7 +921,9 @@
st' = case addMissing afterchunks of
[] -> st{ rightCursor = Cursor Nothing
- (eltchunk : befores left') [] }
+ (eltchunk : befores left') []
+ , middleBalance = 0
+ , middleHasBracket = False }
(y:ys) ->
let lbs = befores left'
in st{
@@ -888,6 +931,8 @@
Cursor (Just eltchunk) lbs (y:ys)
, rightCursor = fixSingleQuote $
Cursor (Just y) (eltchunk:lbs) ys
+ , middleBalance = 0
+ , middleHasBracket = False
, stackBottoms =
-- if a link, we need to ensure that
-- nothing matches as link containing it
@@ -909,19 +954,36 @@
-- inlines, and a close bracket ].
_ ->
processBs bracketedSpecs
- st{ leftCursor = moveLeft left }
+ st{ leftCursor = moveLeft left
+ -- the middle absorbs the opener:
+ , middleBalance = middleBalance st +
+ bracketChunkToNumber opener
+ , middleHasBracket = True }
- (_, Just (Chunk Delim{ delimType = ']' } _ _))
- -> processBs bracketedSpecs st{ leftCursor = moveLeft left }
+ (Just lchunk, Just (Chunk Delim{ delimType = ']' } _ _))
+ -> processBs bracketedSpecs
+ st{ leftCursor = moveLeft left
+ -- the middle absorbs the old left center:
+ , middleBalance = middleBalance st +
+ bracketChunkToNumber lchunk
+ , middleHasBracket = middleHasBracket st ||
+ isBracketChunk lchunk }
(Just _, Just (Chunk Delim{ delimType = '[' } _ _))
-> processBs bracketedSpecs
st{ leftCursor = right
- , rightCursor = moveRight right }
+ , rightCursor = moveRight right
+ , middleBalance = 0
+ , middleHasBracket = False }
(_, _) -> processBs bracketedSpecs
- st{ rightCursor = moveRight right }
+ st{ rightCursor = moveRight right
+ -- the middle absorbs the old right center:
+ , middleBalance = middleBalance st +
+ maybe 0 bracketChunkToNumber (center right)
+ , middleHasBracket = middleHasBracket st ||
+ maybe False isBracketChunk (center right) }
-- This just changes a single quote Delim that occurs
@@ -977,6 +1039,8 @@
satisfyTok (\case
Tok (Symbol '\\') _ _ -> True
Tok (Symbol ')') _ _ -> numparens >= 1
+ -- spec: no ASCII control characters
+ Tok (Symbol c) _ _ -> c >= ' ' && c /= '\x7F'
Tok Spaces _ _ -> False
Tok LineEnd _ _ -> False
_ -> True)
diff --git a/src/Commonmark/Tokens.hs b/src/Commonmark/Tokens.hs
--- a/src/Commonmark/Tokens.hs
+++ b/src/Commonmark/Tokens.hs
@@ -33,10 +33,13 @@
deriving (Show, Eq, Ord, Data, Typeable)
-- | Convert a 'Text' into a list of 'Tok'. The first parameter
--- species the source name.
+-- species the source name. The text is normalized to NFC, and
+-- U+0000 is replaced with U+FFFD, as required by the spec
+-- (section 2.3, Insecure characters).
tokenize :: String -> Text -> [Tok]
tokenize name =
- {-# SCC tokenize #-} go (initialPos name) . T.groupBy f . normalize NFC
+ {-# SCC tokenize #-} go (initialPos name) . T.groupBy f .
+ T.replace "\x0" "\xFFFD" . normalize NFC
where
-- We group \r\n, consecutive spaces, and consecutive alphanums;
-- everything else gets in a token by itself.
@@ -70,7 +73,8 @@
go (incSourceColumn pos 1) ts
-- | Reverses 'tokenize'. @untokenize . tokenize@ should be
--- the identity.
+-- the identity on text that is NFC-normalized and does not
+-- contain U+0000.
untokenize :: [Tok] -> Text
untokenize = {-# SCC untokenize #-} mconcat . map tokContents
diff --git a/test/regression.md b/test/regression.md
--- a/test/regression.md
+++ b/test/regression.md
@@ -507,3 +507,12 @@
a
a
````````````````````````````````
+
+cmark#383
+
+```````````````````````````````` example
+*****Hello*world****
+.
+**Helloworld
+````````````````````````````````
+
diff --git a/test/test-commonmark.hs b/test/test-commonmark.hs
--- a/test/test-commonmark.hs
+++ b/test/test-commonmark.hs
@@ -34,6 +34,7 @@
]
defaultMain $ testGroup "Tests"
(testProperty "tokenize/untokenize roundtrip" tokenize_roundtrip
+ : pathologicalTests defaultParser
: toSpecTest defaultParser
SpecTest
{ section = "Issue #24 (eof after HTML block)"
@@ -50,6 +51,14 @@
, end_line = 2
, start_line = 2
, html = "" }
+ : toSpecTest defaultParser
+ SpecTest
+ { section = "Control character in link destination"
+ , example = 1
+ , markdown = "[foo](de\x01st)\n"
+ , end_line = 1
+ , start_line = 1
+ , html = "[foo](de\x01st)
\n" }
: tests)
getSpecTestTree :: FilePath
@@ -99,6 +108,89 @@
(parser (tokenize "" (markdown st))
:: Either ParseError (Html ()))
+-- Pathological tests, ported from commonmark.js's test/test.js.
+-- Each case must produce the expected output within the timeout;
+-- a timeout indicates nonlinear (typically quadratic) behavior.
+pathologicalTests :: ([Tok] -> Either ParseError (Html ()))
+ -> TestTree
+pathologicalTests parser =
+ localOption (mkTimeout (5 * 1000000)) $ -- 5 seconds per case
+ testGroup "Pathological cases" $
+ map toPathTest pathologicalCases
+ where
+ toPathTest (name, inp, expected) =
+ testCase name $
+ (normalizeHtml . TL.toStrict . renderHtml . fromRight mempty)
+ (parser (tokenize "" inp))
+ @?= normalizeHtml expected
+
+pathologicalCases :: [(String, Text, Text)]
+pathologicalCases =
+ [ ("U+0000 in input",
+ "abc\0xyz\0\n",
+ "abc\65533\&xyz\65533
\n")
+ , ("alternate line endings",
+ "- a\n- b\r- c\r\n- d",
+ "\n")
+ , ("paragraph of 200000 words",
+ rep 200000 "lorem ",
+ "" <> rep 199999 "lorem " <> "lorem
\n")
+ ] ++
+ concatMap forSize [1000, 10000] ++
+ map backslashTitle [10, 100, 1000]
+ where
+ rep = T.replicate
+ forSize :: Int -> [(String, Text, Text)]
+ forSize x =
+ let sx = show x
+ n = rep x
+ in
+ [ ("nested strong emph " <> sx <> " deep",
+ n "*a **a " <> "b" <> n " a** a*",
+ "" <> n "a a " <> "b" <>
+ n " a a" <> "
\n")
+ , (sx <> " emph closers with no openers",
+ n "a_ ",
+ "" <> rep (x - 1) "a_ " <> "a_
\n")
+ , (sx <> " emph openers with no closers",
+ n "_a ",
+ "" <> rep (x - 1) "_a " <> "_a
\n")
+ , (sx <> " openers and closers multiple of 3",
+ "a**b" <> n "c* ",
+ "a**b" <> rep (x - 1) "c* " <> "c*
\n")
+ , (sx <> " #172",
+ n "*_* _ ",
+ "" <> rep (x - 1) "_ _ " <> "_ _
\n")
+ , (sx <> " link closers with no openers",
+ n "a] ",
+ "" <> rep (x - 1) "a] " <> "a]
\n")
+ , (sx <> " link openers with no closers",
+ n "[a ",
+ "" <> rep (x - 1) "[a " <> "[a
\n")
+ , (sx <> " link openers and emph closers",
+ n "[ a_ ",
+ "" <> rep (x - 1) "[ a_ " <> "[ a_
\n")
+ , (sx <> " mismatched openers and closers",
+ n "*a_ ",
+ "" <> rep (x - 1) "*a_ " <> "*a_
\n")
+ , (sx <> " pattern [ (](",
+ n "[ (](",
+ "" <> n "[ (](" <> "
\n")
+ , ("nested brackets " <> sx <> " deep",
+ n "[" <> "a" <> n "]",
+ "" <> n "[" <> "a" <> n "]" <> "
\n")
+ , ("nested block quote " <> sx <> " deep",
+ n "> " <> "a\n",
+ n "\n" <> "a
\n" <> n "
\n")
+ , ("[\\\\... " <> sx <> " deep",
+ "[" <> n "\\" <> "\n",
+ "[" <> rep (x `div` 2) "\\" <> "
\n")
+ ]
+ backslashTitle x =
+ (show x <> " backslashes in unclosed link title",
+ "[test](\\url \"" <> rep x "\\" <> "\n",
+ "[test](\\url "" <> rep (x `div` 2) "\\" <> "
\n")
+
normalizeHtml :: Text -> Text
normalizeHtml = T.replace "\n" "" .
T.replace "\n" ""
@@ -109,7 +201,7 @@
tokenize_roundtrip :: String -> Bool
tokenize_roundtrip s = untokenize (tokenize "source" t) == t
- where t = normalize NFC $ T.pack s
+ where t = T.replace "\0" "\xFFFD" . normalize NFC $ T.pack s
--- parser for spec test cases