microformats2-parser 1.0.1.3 → 1.0.1.4

raw patch · 12 files changed

+120/−103 lines, 12 filesdep +base-compatdep −stringablesetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base-compat

Dependencies removed: stringable

API changes (from Hackage documentation)

Files

• README.md +3/−3
• Setup.hs +2/−0
• executable/Main.hs +2/−5
• library/Data/Microformats2/Parser.hs +9/−19
• library/Data/Microformats2/Parser/Date.hs +2/−5
• library/Data/Microformats2/Parser/HtmlUtil.hs +51/−46
• library/Data/Microformats2/Parser/Property.hs +3/−4
• library/Data/Microformats2/Parser/Util.hs +14/−6
• microformats2-parser.cabal +6/−4
• test-suite/Data/Microformats2/Parser/HtmlUtilSpec.hs +3/−2
• test-suite/Data/Microformats2/Parser/PropertySpec.hs +2/−4
• test-suite/Data/Microformats2/ParserSpec.hs +23/−5

@@ -5,7 +5,7 @@ Originally created for [sweetroll].  - parses `items`, `rels`, `rel-urls`-- resolves relative URLs (with support for the `<base>` tag)+- resolves relative URLs (with support for the `<base>` tag), including inside of `html` for `e-*` properties - parses the [value-class-pattern](http://microformats.org/wiki/value-class-pattern), including date and time normalization - handles malformed HTML (the actual HTML parser is [tagstream-conduit]) - high performance@@ -54,9 +54,9 @@ ```bash $ stack build -$ stack test && rm tests.tix+$ stack test -$ stack ghci --ghc-options="-fno-hpc"+$ stack ghci ```  [stack]: https://github.com/commercialhaskell/stack

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -1,11 +1,9 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE OverloadedStrings, UnicodeSyntax, CPP #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax #-}  module Main (main) where -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import           Prelude.Compat import           Control.Exception import           Data.Microformats2.Parser import           Data.List@@ -15,7 +13,6 @@ import           Data.Default import qualified Data.Text.Lazy as TL import           Data.Streaming.Network (bindPath)-import qualified Data.Stringable as S import           Network.Wai.Handler.Warp import qualified Network.Wai.Handler.CGI as CGI import           Network.Wai.Middleware.Autohead

@@ -1,4 +1,4 @@-{-# LANGUAGE UnicodeSyntax, OverloadedStrings, CPP #-}+{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, OverloadedStrings #-}  module Data.Microformats2.Parser (   Mf2ParserSettings (..)@@ -11,11 +11,9 @@ , sinkDoc ) where +import           Prelude.Compat import           Text.HTML.DOM import           Text.XML.Lens hiding ((.=))-#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif import           Data.Microformats2.Parser.Property import           Data.Microformats2.Parser.HtmlUtil import           Data.Microformats2.Parser.Util@@ -24,7 +22,6 @@ import           Data.Aeson.Types import           Data.Aeson.Lens import           Data.Char (isSpace)-import           Data.List (isPrefixOf) import qualified Data.HashMap.Strict as HMS import qualified Data.Vector as V import           Data.Maybe@@ -51,11 +48,12 @@ extractProperty ∷ Mf2ParserSettings → T.Text → Element → Value extractProperty _ "p"  e = fromMaybe Null $ String <$> extractP e extractProperty s "u"  e = fromMaybe Null $ String <$> case extractU e of-                                                         Just (u, True) → Just $ resolveUrl s u+                                                         Just (u, True) → Just $ resolveURI (baseUri s) u                                                          Just (t, False) → Just t                                                          Nothing → Nothing extractProperty _ "dt" e = fromMaybe Null $ String <$> extractDt e-extractProperty s "e"  e = object [ "html" .= getProcessedInnerHtml (htmlMode s) e, "value" .= getInnerTextRaw e ]+extractProperty s "e"  e = object [ "html" .= getProcessedInnerHtml (htmlMode s) (baseUri s) e+                                  , "value" .= getInnerTextRaw e ] extractProperty _ _    _ = Null  -- lens-aeson's 'key' doesn't add new keys :-(@@ -68,10 +66,10 @@ addValue _   x            _ = x  addImpliedProperties ∷ Mf2ParserSettings → Element → Value → Value-addImpliedProperties settings e v@(Object o) = Object $ addIfNull "photo" "photo" resolveUrl' $ addIfNull "url" "url" resolveUrl' $ addIfNull "name" "name" id o+addImpliedProperties settings e v@(Object o) = Object $ addIfNull "photo" "photo" resolveURI' $ addIfNull "url" "url" resolveURI' $ addIfNull "name" "name" id o   where addIfNull nameJ nameH f obj = if isNothing $ v ^? key nameJ then HMS.insert nameJ (singleton $ f <$> implyProperty nameH e) obj else obj         singleton x = fromMaybe Null $ (Array . V.singleton . String) <$> x-        resolveUrl' = resolveUrl settings+        resolveURI' = resolveURI $ baseUri settings addImpliedProperties _ _ v = v  removePropertiesOfNestedMicroformats ∷ [Element] → [Element] → [Element]@@ -108,9 +106,9 @@ parseMf2 ∷ Mf2ParserSettings → Element → Value parseMf2 settings rootEl = object [ "items" .= items, "rels" .= rels, "rel-urls" .= relUrls ]   where items = map (parseH settings') $ deduplicateElements $ rootEl' ^.. entire . mf2Elements-        rels = object $ map (\(r, es) → r .= map snd es) $ groupBy' fst $ expandSnd $ map (\e → (T.split isSpace (e ^. attr "rel"), resolveUrl settings' $ e ^. attr "href")) linkEls+        rels = object $ map (\(r, es) → r .= map snd es) $ groupBy' fst $ expandSnd $ map (\e → (T.split isSpace (e ^. attr "rel"), resolveURI (baseUri settings') $ e ^. attr "href")) linkEls         relUrls = object $ map relUrlObject linkEls-        relUrlObject e = resolveUrl settings' (e ^. attr "href") .= object (filter (not . emptyVal . snd) [+        relUrlObject e = resolveURI (baseUri settings') (e ^. attr "href") .= object (filter (not . emptyVal . snd) [             "rels" .= T.split isSpace (e ^. attr "rel")           , "text" .= fromMaybe Null (String <$> getInnerTextWithImgs e)           , linkAttr "type" "type" e@@ -125,14 +123,6 @@                                            (Nothing, Just tU) → Just tU                                            (Nothing, Nothing) → Nothing }         rootEl' = preprocessHtml rootEl--resolveUrl ∷ Mf2ParserSettings → T.Text → T.Text-resolveUrl settings t =-  case parseURIReference $ resolveSlashSlash $ T.unpack t of-    Just u → T.pack $ uriToString id (u `relativeTo` baseUri') ""-    Nothing → t-  where resolveSlashSlash x = if "//" `isPrefixOf` x then uriScheme baseUri' ++ x else x-        baseUri' = fromMaybe nullURI (baseUri settings)  preprocessHtml ∷ Element → Element preprocessHtml (Element n as ns) = Element (lowerName n) as $ map preprocessChildren $ filter (not . isTemplate) ns

@@ -1,12 +1,9 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-{-# LANGUAGE OverloadedStrings, UnicodeSyntax, CPP, TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, TypeFamilies #-}  module Data.Microformats2.Parser.Date where -#if !MIN_VERSION_base(4,8,0)-import           Prelude hiding (sequence)-import           Data.Traversable-#endif+import           Prelude.Compat import           Control.Applicative import           Control.Monad import           Control.Error.Util (hush)

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-}-{-# LANGUAGE CPP, RankNTypes #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, RankNTypes  #-}  module Data.Microformats2.Parser.HtmlUtil (   HtmlContentMode (..)@@ -11,9 +10,7 @@ , deduplicateElements ) where -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import           Prelude.Compat import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as TL@@ -24,67 +21,75 @@ import           Text.Blaze.Renderer.Text import           Text.HTML.SanitizeXSS import           Text.XML.Lens hiding (re)+import           Network.URI import           Data.Microformats2.Parser.Util -getPrism ∷ Prism' Node Text → Element → Maybe Text-getPrism t e = Just . T.strip <$> T.concat $ e ^.. nodes . traverse . t+resolveHrefSrc ∷ Maybe URI → Element → Element+resolveHrefSrc b e = e { elementAttributes = M.adjust (resolveURI b) "href" $ M.adjust (resolveURI b) "href" $ elementAttributes e } -_InnerHtml ∷ Prism' Node Text-_InnerHtml = prism' NodeContent $ \s → case s of-  NodeContent c → Just $ collapseWhitespace c-  NodeElement e → Just . TL.toStrict . renderMarkup . toMarkup $ e-  _ → Nothing+processChildren ∷ (Node → Node) → Element → Element+processChildren f e = e { elementNodes = map f $ elementNodes e } -getInnerHtml ∷ Element → Maybe Text-getInnerHtml = getPrism _InnerHtml+filterChildElements ∷ (Element → Bool) → Element → Element+filterChildElements f e = e { elementNodes = filter f' $ elementNodes e }+  where f' (NodeContent _) = True+        f' (NodeElement e') = f e'+        f' _ = False +renderInner ∷ Element → Text+renderInner = T.concat . map renderNode . elementNodes+  where renderNode (NodeContent c) = c+        renderNode (NodeElement e) = TL.toStrict $ renderMarkup $ toMarkup e+        renderNode _ = ""++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 (NodeElement e) = NodeElement $ processChildren processNode $ resolveHrefSrc b e+        processNode x = x+ sanitizeAttrs ∷ Element → Element sanitizeAttrs e = e { elementAttributes = M.fromList $ map wrapName $ mapMaybe modify $ M.toList $ elementAttributes e }   where modify (Name n _ _, val) = sanitizeAttribute (n, val)         wrapName (n, val) = (Name n Nothing Nothing, val) -_InnerHtmlSanitized ∷ Prism' Node Text-_InnerHtmlSanitized = prism' NodeContent $ \s → case s of-  NodeContent c → Just $ collapseWhitespace c-  NodeElement e → if' (safeTagName $ nameLocalName (elementName e)) $-                    Just . TL.toStrict . renderMarkup . toMarkup $ sanitizeAttrs e-  _ → Nothing--getInnerHtmlSanitized ∷ Element → Maybe Text-getInnerHtmlSanitized = getPrism _InnerHtmlSanitized--_InnerTextRaw ∷ Prism' Node Text-_InnerTextRaw = prism' NodeContent $ \s → case s of-  NodeContent c → Just . collapseWhitespace $ c-  NodeElement e → if' (safeTagName $ nameLocalName (elementName e)) $-                    Just . collapseWhitespace . TL.toStrict . renderMarkup . contents . toMarkup $ e-  _ → Nothing--_InnerTextWithImgs ∷ Prism' Node Text-_InnerTextWithImgs = prism' NodeContent $ \s → case s of-  NodeContent c → Just $ collapseWhitespace c-  NodeElement e → if nameLocalName (elementName e) == "img"-                    then asum [ e ^. attribute "alt", e ^. attribute "src" ]-                    else Just . collapseWhitespace . TL.toStrict . renderMarkup . contents . toMarkup $ e-  _ → Nothing+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 (NodeElement e) = NodeElement $ processChildren processNode $ filterChildElements (safeTagName . nameLocalName . elementName) $ resolveHrefSrc b $ sanitizeAttrs e+        processNode x = x  getInnerTextRaw ∷ Element → Maybe Text-getInnerTextRaw e = unless' (txt == Just "") txt-  where txt = getPrism _InnerTextRaw e+getInnerTextRaw rootEl = unless' (txt == Just "") txt+  where txt = Just $ T.dropAround (== ' ') $ collapseWhitespace 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 x = x  getInnerTextWithImgs ∷ Element → Maybe Text-getInnerTextWithImgs e = unless' (txt == Just "") txt-  where txt = getPrism _InnerTextWithImgs e+getInnerTextWithImgs rootEl = unless' (txt == Just "") txt+  where txt = Just $ T.dropAround (== ' ') $ collapseWhitespace processedRoot+        (NodeContent processedRoot) = processNode (NodeElement rootEl)+        processNode (NodeContent c) = NodeContent $ collapseWhitespace $ 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 x = x  data HtmlContentMode = Unsafe | Escape | Sanitize   deriving (Show, Eq) -getProcessedInnerHtml ∷ HtmlContentMode → Element → Maybe Text-getProcessedInnerHtml Unsafe   e = getInnerHtml e-getProcessedInnerHtml Escape   e = (T.replace "<" "&lt;" . T.replace ">" "&gt;" . T.replace "&" "&amp;") <$> getInnerHtml e-getProcessedInnerHtml Sanitize e = getInnerHtmlSanitized e+getProcessedInnerHtml ∷ HtmlContentMode → Maybe URI → Element → Maybe Text+getProcessedInnerHtml Unsafe   b e = getInnerHtml b e+getProcessedInnerHtml Escape   b e = escapeHtml <$> getInnerHtml b e+getProcessedInnerHtml Sanitize b e = getInnerHtmlSanitized b e  deduplicateElements ∷ [Element] → [Element] deduplicateElements es = filter (not . isNested) es   where isNested e = any (\e' → e `elem` filter (/= e') (e' ^.. entire)) es         -- not the fastest function I guess...++escapeHtml ∷ Text → Text+escapeHtml = T.replace "<" "&lt;" . T.replace ">" "&gt;" . T.replace "&" "&amp;"

@@ -1,11 +1,10 @@-{-# LANGUAGE OverloadedStrings, QuasiQuotes, UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, QuasiQuotes, UnicodeSyntax #-} {-# LANGUAGE CPP, RankNTypes, TupleSections #-}+-- LOL: CPP is required for the \ linebreak thing  module Data.Microformats2.Parser.Property where -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import           Prelude.Compat import qualified Data.Text as T import           Data.Text (Text) import           Data.Char (isSpace)

@@ -1,18 +1,18 @@-{-# LANGUAGE OverloadedStrings, QuasiQuotes, UnicodeSyntax #-}-{-# LANGUAGE CPP, TupleSections #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, QuasiQuotes, UnicodeSyntax, TupleSections #-}  module Data.Microformats2.Parser.Util where -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import           Prelude.Compat import           Data.Aeson+import           Data.Maybe+import           Data.List (isPrefixOf) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.HashMap.Strict as HMS import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.Foldable as F+import           Network.URI import           Text.Regex.PCRE.Heavy  if' ∷ Bool → Maybe a → Maybe a@@ -28,7 +28,7 @@ stripQueryString = TL.intercalate "" . take 1 . TL.splitOn "?" . TL.strip  collapseWhitespace ∷ T.Text → T.Text-collapseWhitespace = gsub [re|(\s+|&nbsp;)|] (" " ∷ String)+collapseWhitespace = gsub [re|(\s|&nbsp;)+|] (" " ∷ String)  emptyVal ∷ Value → Bool emptyVal (Object o) = HMS.null o@@ -43,3 +43,11 @@ -- https://hackage.haskell.org/package/liquid-fixpoint-0.4.0.0/docs/src/Language-Fixpoint-Misc.html#expandSnd expandSnd ∷ F.Foldable φ ⇒ φ ([α], β) → [(α, β)] expandSnd = F.concatMap (\(xs, y) → (, y) <$> xs)++resolveURI ∷ Maybe URI → T.Text → T.Text+resolveURI b t =+  case parseURIReference $ resolveSlashSlash $ T.unpack t of+    Just u → T.pack $ uriToString id (u `relativeTo` baseUri') ""+    Nothing → t+  where resolveSlashSlash x = if "//" `isPrefixOf` x then uriScheme baseUri' ++ x else x+        baseUri' = fromMaybe nullURI b

@@ -1,5 +1,5 @@ name:            microformats2-parser-version:         1.0.1.3+version:         1.0.1.4 synopsis:        A Microformats 2 parser. category:        Web homepage:        https://github.com/myfreeweb/microformats2-parser@@ -13,7 +13,7 @@ extra-source-files:     README.md tested-with:-    GHC == 7.10.2+    GHC == 7.10.3  source-repository head     type: git@@ -22,6 +22,7 @@ library     build-depends:         base >= 4.7.0.0 && < 5+      , base-compat >= 0.8.0       , transformers       , text       , bytestring@@ -56,13 +57,13 @@ executable microformats2-parser     build-depends:         base >= 4.7.0.0 && < 5+      , base-compat >= 0.8.0       , options       , warp       , wai-extra       , network       , network-uri       , streaming-commons-      , stringable       , data-default       , text       , scotty@@ -80,6 +81,7 @@ test-suite tests     build-depends:         base >= 4.7.0.0 && < 5+      , base-compat >= 0.8.0       , mtl       , time       , text@@ -95,7 +97,7 @@       , html-conduit       , xml-lens     default-language: Haskell2010-    ghc-options: -threaded -Wall -fhpc+    ghc-options: -threaded -Wall     hs-source-dirs: test-suite     main-is: Spec.hs     other-modules:

@@ -1,7 +1,8 @@-{-# LANGUAGE OverloadedStrings, UnicodeSyntax, QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, QuasiQuotes #-}  module Data.Microformats2.Parser.HtmlUtilSpec (spec) where +import           Prelude.Compat import           Test.Hspec import           TestCommon import           Data.Microformats2.Parser.HtmlUtil@@ -12,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

@@ -1,13 +1,11 @@-{-# LANGUAGE OverloadedStrings, UnicodeSyntax, QuasiQuotes, CPP #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, QuasiQuotes #-}  module Data.Microformats2.Parser.PropertySpec (spec) where +import           Prelude.Compat import           Test.Hspec import           TestCommon import           Data.Microformats2.Parser.Property-#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif  {-# ANN module ("HLint: ignore Redundant do"::String) #-} 

@@ -1,9 +1,10 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, OverloadedStrings, UnicodeSyntax #-}  module Data.Microformats2.ParserSpec (spec) where -import           Test.Hspec hiding (shouldBe)-import           Test.Hspec.Expectations.Pretty (shouldBe)+import           Prelude.Compat+import           Test.Hspec --hiding (shouldBe)+--import           Test.Hspec.Expectations.Pretty (shouldBe) import           TestCommon import           Network.URI (parseURI) import           Data.Microformats2.Parser@@ -16,7 +17,7 @@     it "parses items" $ do       parseMf2' [xml|<body>   <div class="h-something aaa h-something-else">-    <h1 class="someclass p-name eeee">Name</h1>+    <h1 class="someclass p-name eeee">Name <script>xxx</script></h1>     <header><A class="p-name u-url" href="http://main.url">other name</a></header>     <span class="aaaaaap-nothingaaaa">---</span>     <div class="e-content">Some <abbr>XSS</abbr><script>alert('pwned')</script></div>@@ -89,7 +90,22 @@     ],     "rels": {},     "rel-urls": {}+}|] +    it "does not allow html in text nodes" $ do+      -- there was a bug where &lt;script&gt; would become <script> in content[value], name, etc.+      parseMf2' [xml|<body class=h-entry><div class=e-content>hello <b>&#039;<script></script>&lt;script&gt;&lt;/script&gt;&#039;</div>|] `shouldBe` [json|{+    "items": [+        {+            "type": [ "h-entry" ],+            "properties": {+                "content": [ { "value": "hello '&lt;script&gt;&lt;/script&gt;'", "html": "hello <b>&#39;&amp;lt;script&amp;gt;&amp;lt;/script&amp;gt;&#39;</b>" } ],+                "name": [ "hello '&lt;script&gt;&lt;/script&gt;'" ]+            }+        }+    ],+    "rels": {},+    "rel-urls": {} }|]      it "inserts value and html into e-* h-* properties" $ do@@ -230,6 +246,7 @@     <a href="url" class=u-url>url</a>     <span href="url" class=u-url><span class=value>/not</span>!!!<em class=value>/resolved</em></span>     <img src="photo.webp" alt="photo of me"> <!-- implied by :only-of-type -->+    <div class=e-content><p><a href="/hello">Hello!</a></p></div>   </div> </html>|] `shouldBe` [json|{     "items": [@@ -238,7 +255,8 @@             "properties": {                 "photo": [ "http://com.example/base/photo.webp" ],                 "url": [ "http://com.example/base/url", "/not/resolved" ],-                "name": [ "card" ]+                "name": [ "card" ],+                "content": [ { "html": "<p><a href=\"http://com.example/hello\">Hello!</a></p>", "value": "Hello!" } ]             }         }     ],