diff --git a/library/Data/Microformats2/Parser.hs b/library/Data/Microformats2/Parser.hs --- a/library/Data/Microformats2/Parser.hs +++ b/library/Data/Microformats2/Parser.hs @@ -4,6 +4,7 @@ Mf2ParserSettings (..) , HtmlContentMode (..) , parseMf2 +, extractProperty -- * HTML parsing stuff (from html-conduit, xml-lens) , documentRoot diff --git a/library/Data/Microformats2/Parser/HtmlUtil.hs b/library/Data/Microformats2/Parser/HtmlUtil.hs --- a/library/Data/Microformats2/Parser/HtmlUtil.hs +++ b/library/Data/Microformats2/Parser/HtmlUtil.hs @@ -8,18 +8,25 @@ , getInnerTextWithImgs , getProcessedInnerHtml , deduplicateElements +, unescapeHtml ) where import Prelude.Compat +import Control.Applicative ((<|>)) +import Control.Error.Util (hush) +import Data.Monoid.Compat import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text (Text) +import Data.Char (isSpace) import Data.Foldable (asum) +import Data.Attoparsec.Text import Data.Maybe import Text.Blaze import Text.Blaze.Renderer.Text import Text.HTML.SanitizeXSS +import Text.HTML.TagSoup.Entity import Text.XML.Lens hiding (re) import Network.URI import Data.Microformats2.Parser.Util @@ -45,7 +52,7 @@ getInnerHtml ∷ Maybe URI → Element → Maybe Text getInnerHtml b rootEl = Just $ renderInner processedRoot where (NodeElement processedRoot) = processNode (NodeElement rootEl) - processNode (NodeContent c) = NodeContent $ collapseWhitespace c + processNode (NodeContent c) = NodeContent c processNode (NodeElement e) = NodeElement $ processChildren processNode $ resolveHrefSrc b e processNode x = x @@ -57,25 +64,25 @@ getInnerHtmlSanitized ∷ Maybe URI → Element → Maybe Text getInnerHtmlSanitized b rootEl = Just $ renderInner processedRoot where (NodeElement processedRoot) = processNode (NodeElement rootEl) - processNode (NodeContent c) = NodeContent $ collapseWhitespace $ escapeHtml c + processNode (NodeContent c) = NodeContent c processNode (NodeElement e) = NodeElement $ processChildren processNode $ filterChildElements (safeTagName . nameLocalName . elementName) $ resolveHrefSrc b $ sanitizeAttrs e processNode x = x getInnerTextRaw ∷ Element → Maybe Text getInnerTextRaw rootEl = unless' (txt == Just "") txt - where txt = Just $ T.dropAround (== ' ') $ collapseWhitespace processedRoot + where txt = Just $ T.dropAround isSpace $ processedRoot (NodeContent processedRoot) = processNode (NodeElement rootEl) - processNode (NodeContent c) = NodeContent $ collapseWhitespace $ escapeHtml c - processNode (NodeElement e) = NodeContent $ collapseWhitespace $ renderInner $ processChildren processNode $ filterChildElements (safeTagName . nameLocalName . elementName) e + processNode (NodeContent c) = NodeContent $ escapeHtml c + processNode (NodeElement e) = NodeContent $ T.dropAround isSpace $ renderInner $ processChildren processNode $ filterChildElements (safeTagName . nameLocalName . elementName) e processNode x = x getInnerTextWithImgs ∷ Element → Maybe Text getInnerTextWithImgs rootEl = unless' (txt == Just "") txt - where txt = Just $ T.dropAround (== ' ') $ collapseWhitespace processedRoot + where txt = Just $ T.dropAround isSpace $ processedRoot (NodeContent processedRoot) = processNode (NodeElement rootEl) - processNode (NodeContent c) = NodeContent $ collapseWhitespace $ escapeHtml c + processNode (NodeContent c) = NodeContent $ escapeHtml c processNode (NodeElement e) | nameLocalName (elementName e) == "img" = NodeContent $ fromMaybe "" $ asum [ e ^. attribute "alt", e ^. attribute "src" ] - processNode (NodeElement e) = NodeContent $ collapseWhitespace $ renderInner $ processChildren processNode $ filterChildElements (safeTagName . nameLocalName . elementName) e + processNode (NodeElement e) = NodeContent $ T.dropAround isSpace $ renderInner $ processChildren processNode $ filterChildElements (safeTagName . nameLocalName . elementName) e processNode x = x data HtmlContentMode = Unsafe | Escape | Sanitize @@ -93,3 +100,12 @@ escapeHtml ∷ Text → Text escapeHtml = T.replace "<" "<" . T.replace ">" ">" . T.replace "&" "&" + +unescapeHtml ∷ Text → Text +unescapeHtml x = fromMaybe x $ T.concat <$> hush (parseOnly p x) + where p = many1 $ takeWhile1 (/= '&') <|> pent + pent = do + char '&' + ent ← takeWhile1 (/= ';') + char ';' + return $ fromMaybe ("&" <> ent <> ";") $ T.pack <$> lookupEntity (T.unpack ent) diff --git a/library/Data/Microformats2/Parser/Property.hs b/library/Data/Microformats2/Parser/Property.hs --- a/library/Data/Microformats2/Parser/Property.hs +++ b/library/Data/Microformats2/Parser/Property.hs @@ -93,7 +93,7 @@ extractU ∷ Element → Maybe (Text, Bool) -- ^ The Microformats 2 spec requires URL resolution only in some cases. The Bool here is whether you should resolve the result. -extractU e = +extractU e = fmap (& _1 %~ unescapeHtml) $ asum $ [ (, True) <$> getAAreaHref e , (, True) <$> getImgAudioVideoSourceSrc e , (, True) <$> getObjectData e diff --git a/microformats2-parser.cabal b/microformats2-parser.cabal --- a/microformats2-parser.cabal +++ b/microformats2-parser.cabal @@ -1,5 +1,5 @@ name: microformats2-parser -version: 1.0.1.4 +version: 1.0.1.5 synopsis: A Microformats 2 parser. category: Web homepage: https://github.com/myfreeweb/microformats2-parser @@ -39,6 +39,7 @@ , data-default , html-conduit , xml-lens + , tagsoup , network-uri , blaze-markup , xss-sanitize diff --git a/test-suite/Data/Microformats2/Parser/HtmlUtilSpec.hs b/test-suite/Data/Microformats2/Parser/HtmlUtilSpec.hs --- a/test-suite/Data/Microformats2/Parser/HtmlUtilSpec.hs +++ b/test-suite/Data/Microformats2/Parser/HtmlUtilSpec.hs @@ -13,7 +13,7 @@ it "returns textContent without handling imgs" $ do let txtraw = getInnerTextRaw . documentRoot . parseLBS txtraw [xml|
This is text content NOPE without any stuff. -
|] `shouldBe` Just "This is text content without any stuff." + |] `shouldBe` Just "This is text content without any stuff." describe "getInnerTextWithImgs" $ do it "returns textContent with handling imgs" $ do diff --git a/test-suite/Data/Microformats2/Parser/PropertySpec.hs b/test-suite/Data/Microformats2/Parser/PropertySpec.hs --- a/test-suite/Data/Microformats2/Parser/PropertySpec.hs +++ b/test-suite/Data/Microformats2/Parser/PropertySpec.hs @@ -42,6 +42,7 @@ ur [xml||] `shouldBe` pure ("/yo/data", False) ur [xml||] `shouldBe` pure ("/yo/input", False) ur [xml|/yo/span|] `shouldBe` pure ("/yo/span", False) + ur [xml|link|] `shouldBe` pure ("https://secure.gravatar.com/avatar/947b5f3f323da0ef785b6f02d9c265d6?s=96&d=blank&r=g", True) it "parses dt- properties" $ do let dt = extractDt . documentRoot . parseLBS diff --git a/test-suite/Data/Microformats2/ParserSpec.hs b/test-suite/Data/Microformats2/ParserSpec.hs --- a/test-suite/Data/Microformats2/ParserSpec.hs +++ b/test-suite/Data/Microformats2/ParserSpec.hs @@ -99,7 +99,7 @@ { "type": [ "h-entry" ], "properties": { - "content": [ { "value": "hello '<script></script>'", "html": "hello '&lt;script&gt;&lt;/script&gt;'" } ], + "content": [ { "value": "hello '<script></script>'", "html": "hello '<script></script>'" } ], "name": [ "hello '<script></script>'" ] } } @@ -141,7 +141,7 @@ { "type": [ "h-parent" ], "properties": { - "name": [ "something a b" ], + "name": [ "something\n a\n b" ], "outer": [ "something", "a" ], "inner": [ "some" ], "prop": [ {