microformats2-parser 1.0.1.4 → 1.0.1.5
raw patch · 7 files changed
+32/−13 lines, 7 filesdep +tagsoupPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependencies added: tagsoup
API changes (from Hackage documentation)
+ Data.Microformats2.Parser: extractProperty :: Mf2ParserSettings -> Text -> Element -> Value
+ Data.Microformats2.Parser.HtmlUtil: unescapeHtml :: Text -> Text
Files
- library/Data/Microformats2/Parser.hs +1/−0
- library/Data/Microformats2/Parser/HtmlUtil.hs +24/−8
- library/Data/Microformats2/Parser/Property.hs +1/−1
- microformats2-parser.cabal +2/−1
- test-suite/Data/Microformats2/Parser/HtmlUtilSpec.hs +1/−1
- test-suite/Data/Microformats2/Parser/PropertySpec.hs +1/−0
- test-suite/Data/Microformats2/ParserSpec.hs +2/−2
library/Data/Microformats2/Parser.hs view
@@ -4,6 +4,7 @@ Mf2ParserSettings (..) , HtmlContentMode (..) , parseMf2+, extractProperty -- * HTML parsing stuff (from html-conduit, xml-lens) , documentRoot
library/Data/Microformats2/Parser/HtmlUtil.hs view
@@ -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)
library/Data/Microformats2/Parser/Property.hs view
@@ -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
microformats2-parser.cabal view
@@ -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
test-suite/Data/Microformats2/Parser/HtmlUtilSpec.hs view
@@ -13,7 +13,7 @@ it "returns textContent without handling imgs" $ do let txtraw = getInnerTextRaw . documentRoot . parseLBS txtraw [xml|<div>This is <a href="">text content</a> <img src="/yo" alt="NOPE"> without any stuff.- </div>|] `shouldBe` Just "This is text content without any stuff."+ </div>|] `shouldBe` Just "This is text content without any stuff." describe "getInnerTextWithImgs" $ do it "returns textContent with handling imgs" $ do
test-suite/Data/Microformats2/Parser/PropertySpec.hs view
@@ -42,6 +42,7 @@ ur [xml|<data class="u-url" value="/yo/data"/>|] `shouldBe` pure ("/yo/data", False) ur [xml|<input class="u-url" value="/yo/input"/>|] `shouldBe` pure ("/yo/input", False) ur [xml|<span class="u-url">/yo/span</span>|] `shouldBe` pure ("/yo/span", False)+ ur [xml|<a class="u-url" href="https://secure.gravatar.com/avatar/947b5f3f323da0ef785b6f02d9c265d6?s=96&d=blank&r=g">link</a>|] `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
test-suite/Data/Microformats2/ParserSpec.hs view
@@ -99,7 +99,7 @@ { "type": [ "h-entry" ], "properties": {- "content": [ { "value": "hello '<script></script>'", "html": "hello <b>'&lt;script&gt;&lt;/script&gt;'</b>" } ],+ "content": [ { "value": "hello '<script></script>'", "html": "hello <b>'<script></script>'</b>" } ], "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": [ {