diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,9 @@ + 0.4.3 + * Ensure we don't grow with a negative size in DOM parser (#48) + * Flatten code nesting in process function (#45) + * Introduce a whitespace-around-equals CPP flag (#44) + * Use modify' instead of modify in fold (#42) + 0.4.2 * all benchmarks marked as such in the Cabal file diff --git a/src/Xeno/DOM.hs b/src/Xeno/DOM.hs --- a/src/Xeno/DOM.hs +++ b/src/Xeno/DOM.hs @@ -138,7 +138,9 @@ -- -- predictGrowSize _bsStart _bsLen _index vecLen = round $ fromIntegral vecLen * (1.25 :: Double) predictGrowSize bsStart bsLen index vecLen = - let processedLen = bsStart + bsLen - offset0 + let -- at least 1 so we don't divide by zero below and end up with + -- a negative grow size if (bsStart + bsLen - offset0) == 0 + processedLen = max 1 (bsStart + bsLen - offset0) -- 1. Using integral operations, such as -- "predictedTotalSize = (index * S.length str) `div` processedLen" -- cause overflow, so we use float. diff --git a/src/Xeno/SAX.hs b/src/Xeno/SAX.hs --- a/src/Xeno/SAX.hs +++ b/src/Xeno/SAX.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -192,12 +191,12 @@ spork (execState (process Process { - openF = \name -> modify (\s' -> openF s' name) - , attrF = \key value -> modify (\s' -> attrF s' key value) - , endOpenF = \name -> modify (\s' -> endOpenF s' name) - , textF = \text -> modify (\s' -> textF s' text) - , closeF = \name -> modify (\s' -> closeF s' name) - , cdataF = \cdata -> modify (\s' -> cdataF s' cdata) + openF = \name -> modify' (\s' -> openF s' name) + , attrF = \key value -> modify' (\s' -> attrF s' key value) + , endOpenF = \name -> modify' (\s' -> endOpenF s' name) + , textF = \text -> modify' (\s' -> textF s' text) + , closeF = \name -> modify' (\s' -> closeF s' name) + , cdataF = \cdata -> modify' (\s' -> cdataF s' cdata) } str) s) @@ -221,22 +220,24 @@ checkOpenComment (fromLt + 1) where text = substring' str index fromLt -- Find open comment, CDATA or tag name. - checkOpenComment index = - if | s_index' this 0 == bangChar -- ! - && s_index' this 1 == commentChar -- - - && s_index' this 2 == commentChar -> -- - - findCommentEnd (index + 3) - | s_index' this 0 == bangChar -- ! - && s_index' this 1 == openAngleBracketChar -- [ - && s_index' this 2 == 67 -- C - && s_index' this 3 == 68 -- D - && s_index' this 4 == 65 -- A - && s_index' this 5 == 84 -- T - && s_index' this 6 == 65 -- A - && s_index' this 7 == openAngleBracketChar -> -- [ - findCDataEnd (index + 8) (index + 8) - | otherwise -> - findTagName index + checkOpenComment index + | s_index' this 0 == bangChar -- ! + , s_index' this 1 == commentChar -- - + , s_index' this 2 == commentChar -- - + = findCommentEnd (index + 3) + + | s_index' this 0 == bangChar -- ! + , s_index' this 1 == openAngleBracketChar -- [ + , s_index' this 2 == 67 -- C + , s_index' this 3 == 68 -- D + , s_index' this 4 == 65 -- A + , s_index' this 5 == 84 -- T + , s_index' this 6 == 65 -- A + , s_index' this 7 == openAngleBracketChar -- [ + = findCDataEnd (index + 8) (index + 8) + + | otherwise + = findTagName index where this = drop' index str findCommentEnd index = @@ -258,68 +259,74 @@ else -- We only found one ], that means that we need to keep searching. findCDataEnd cdata_start (fromCloseAngleBracket + 1) - findTagName index0 = - let spaceOrCloseTag = parseName str index - in if | s_index' str index0 == questionChar -> - case elemIndexFrom' closeTagChar str spaceOrCloseTag of - Nothing -> throw $ XenoParseError index "Couldn't find the end of the tag." - Just fromGt -> do - findLT (fromGt + 1) - | s_index' str spaceOrCloseTag == closeTagChar -> - do let tagname = substring' str index spaceOrCloseTag - if s_index' str index0 == slashChar - then closeF tagname - else do - openF tagname - endOpenF tagname - findLT (spaceOrCloseTag + 1) - | otherwise -> - do let tagname = substring' str index spaceOrCloseTag - openF tagname - result <- findAttributes spaceOrCloseTag - endOpenF tagname - case result of - Right closingTag -> findLT (closingTag + 1) - Left closingPair -> do - closeF tagname - findLT (closingPair + 2) + findTagName index0 + | s_index' str index0 == questionChar = + case elemIndexFrom' closeTagChar str spaceOrCloseTag of + Nothing -> throw $ XenoParseError index "Couldn't find the end of the tag." + Just fromGt -> do + findLT (fromGt + 1) + | s_index' str spaceOrCloseTag == closeTagChar = do + let tagname = substring' str index spaceOrCloseTag + if s_index' str index0 == slashChar + then closeF tagname + else do + openF tagname + endOpenF tagname + findLT (spaceOrCloseTag + 1) + | otherwise = do + let tagname = substring' str index spaceOrCloseTag + openF tagname + result <- findAttributes spaceOrCloseTag + endOpenF tagname + case result of + Right closingTag -> findLT (closingTag + 1) + Left closingPair -> do + closeF tagname + findLT (closingPair + 2) where index = if s_index' str index0 == slashChar then index0 + 1 else index0 - findAttributes index0 = - if s_index' str index == slashChar && - s_index' str (index + 1) == closeTagChar - then pure (Left index) - else if s_index' str index == closeTagChar - then pure (Right index) - else let afterAttrName = parseName str index - in if s_index' str afterAttrName == equalChar - then let quoteIndex = afterAttrName + 1 - usedChar = s_index' str quoteIndex - in if usedChar == quoteChar || - usedChar == doubleQuoteChar - then case elemIndexFrom' - usedChar - str - (quoteIndex + 1) of - Nothing -> - throw - (XenoParseError index "Couldn't find the matching quote character.") - Just endQuoteIndex -> do - attrF - (substring' str index afterAttrName) - (substring' - str - (quoteIndex + 1) - (endQuoteIndex)) - findAttributes (endQuoteIndex + 1) - else throw - (XenoParseError index("Expected ' or \", got: " <> S.singleton usedChar)) - else throw (XenoParseError index ("Expected =, got: " <> S.singleton (s_index' str afterAttrName) <> " at character index: " <> (S8.pack . show) afterAttrName)) + spaceOrCloseTag = parseName str index + findAttributes index0 + -- case: /> + | s_index' str index == slashChar + , s_index' str (index + 1) == closeTagChar + = pure (Left index) + + -- case: > + | s_index' str index == closeTagChar + = pure (Right index) + + -- case: attr=' or attr=" + | s_index' str afterAttrName == equalChar + , usedChar == quoteChar || usedChar == doubleQuoteChar + = case elemIndexFrom' usedChar str (quoteIndex + 1) of + Nothing -> + throw + (XenoParseError index "Couldn't find the matching quote character.") + Just endQuoteIndex -> do + attrF + (substring' str index afterAttrName) + (substring' + str + (quoteIndex + 1) + (endQuoteIndex)) + findAttributes (endQuoteIndex + 1) + + -- case: attr= without following quote + | s_index' str afterAttrName == equalChar + = throw (XenoParseError index("Expected ' or \", got: " <> S.singleton usedChar)) + + | otherwise + = throw (XenoParseError index ("Expected =, got: " <> S.singleton (s_index' str afterAttrName) <> " at character index: " <> (S8.pack . show) afterAttrName)) where index = skipSpaces str index0 + afterAttrName = parseName str index + quoteIndex = afterAttrName + 1 + usedChar = s_index' str quoteIndex + {-# INLINE process #-} {-# SPECIALISE process :: Process (Identity ()) -> ByteString -> Identity () #-} diff --git a/xeno.cabal b/xeno.cabal --- a/xeno.cabal +++ b/xeno.cabal @@ -1,5 +1,5 @@ name: xeno -version: 0.4.2 +version: 0.4.3 synopsis: A fast event-based XML parser in pure Haskell description: A fast, low-memory use, event-based XML parser in pure Haskell. build-type: Simple