microformats2-parser 0.1.1 → 1.0.0
raw patch · 12 files changed
+791/−751 lines, 12 filesdep +aesondep +aeson-prettydep +aeson-qqdep −microformats2-types
Dependencies added: aeson, aeson-pretty, aeson-qq, bytestring, hspec-expectations-pretty-diff, lens-aeson, mtl, network-uri, transformers, unordered-containers, vector
Dependencies removed: microformats2-types
Files
- README.md +29/−9
- executable/Main.hs +44/−35
- library/Data/Microformats2/Parser.hs +111/−144
- library/Data/Microformats2/Parser/HtmlUtil.hs +89/−0
- library/Data/Microformats2/Parser/Internal.hs +0/−222
- library/Data/Microformats2/Parser/Property.hs +113/−0
- library/Data/Microformats2/Parser/Util.hs +45/−0
- microformats2-parser.cabal +24/−6
- test-suite/Data/Microformats2/Parser/HtmlUtilSpec.hs +21/−0
- test-suite/Data/Microformats2/Parser/InternalSpec.hs +0/−97
- test-suite/Data/Microformats2/Parser/PropertySpec.hs +94/−0
- test-suite/Data/Microformats2/ParserSpec.hs +221/−238
README.md view
@@ -1,29 +1,49 @@-# microformats2-parser [](https://hackage.haskell.org/package/microformats2-parser) [](https://travis-ci.org/myfreeweb/microformats2-parser) [](https://coveralls.io/r/myfreeweb/microformats2-parser) [](http://unlicense.org)+# microformats2-parser [](https://hackage.haskell.org/package/microformats2-parser) [](https://travis-ci.org/myfreeweb/microformats2-parser) [](http://unlicense.org) -[Microformats 2] parser for Haskell!+[Microformats 2] parser for Haskell! [#IndieWeb] -Originally created for [sweetroll] :-)+Originally created for [sweetroll]. -The types are located in a separate package called [microformats2-types].+- parses `items`, `rels`, `rel-urls`+- resolves relative URLs (with support for the `<base>` tag)+- handles malformed HTML (the actual HTML parser is [tagstream-conduit])+- high performance+- extensively tested +Also check out [http-link-header] because you often need to read links from the Link header!+ [Microformats 2]: http://microformats.org/wiki/microformats2+[#IndieWeb]: http://indiewebcamp.com [sweetroll]: https://github.com/myfreeweb/sweetroll-[microformats2-types]: https://github.com/myfreeweb/microformats2-types+[tagstream-conduit]: https://hackage.haskell.org/package/tagstream-conduit+[http-link-header]: https://github.com/myfreeweb/http-link-header ## [DEMO PAGE](https://unrelenting.technology/mf2/) ## Usage +Look at the API docs [on Hackage](https://hackage.haskell.org/package/microformats2-parser) for more info, here's a quick overview:+ ```haskell {-# LANGUAGE OverloadedStrings #-}+ import Data.Microformats2.Parser-import Data.Microformats2.Types+import Data.Default+import Network.URI -parseEntry Sanitize $ documentRoot $ parseLBS "<body><p class=h-entry><h1 class=p-name>Yay!</h1></p></body>"--- [ Entry { entryName = [ "Yay!" ], ... } ]+parseMf2 def $ documentRoot $ parseLBS "<body><p class=h-entry><h1 class=p-name>Yay!</h1></p></body>"++parseMf2 (def { baseUri = parseURI "https://where.i.got/that/page/from/" }) $ documentRoot $ parseLBS "<body><base href=\"base/\"><link rel=micropub href='micropub'><p class=h-entry><h1 class=p-name>Yay!</h1></p></body>" ``` -Look at the API docs [on Hackage](https://hackage.haskell.org/package/microformats2-parser) for more info.+The `def` is the [default](https://hackage.haskell.org/package/data-default-class-0.0.1/docs/Data-Default-Class.html) configuration.++The configuration includes:+- `htmlMode`, an HTML parsing mode (`Unsafe` | `Escape` | **`Sanitize`**)+- `baseUri`, the `Maybe URI` that represents the address you retrieved the HTML from, used for resolving relative addresses -- you should set it++`parseMf2` will return an Aeson [Value](https://hackage.haskell.org/package/aeson-0.8.0.2/docs/Data-Aeson-Types.html#t:Value) structured like [canonical microformats2 JSON](http://microformats.org/wiki/microformats2).+[lens-aeson](https://hackage.haskell.org/package/lens-aeson) is a good way to navigate it. ## Development
executable/Main.hs view
@@ -7,14 +7,19 @@ import Data.Microformats2.Parser import Data.List import Data.Maybe (fromMaybe)+import Data.Aeson.Encode.Pretty+import Data.Aeson.Types (object)+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 import qualified Network.Socket as S+import Network.URI (parseURI) import Web.Scotty-import Text.Blaze.Html5 as H+import Text.Blaze.Html5 as H hiding (main, param, object) import Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import qualified Options as O@@ -33,52 +38,56 @@ exampleValue = "<body> <p class='h-adr'> <span class='p-street-address'>17 Austerstræti</span> <span class='p-locality'>Reykjavík</span> <span class='p-country-name'>Iceland</span> <span class='p-postal-code'>107</span> </p> <div class='h-card'> <a class='p-name u-url' href='http://blog.lizardwrangler.com/' >Mitchell Baker</a> (<a class='p-org h-card' href='http://mozilla.org/' >Mozilla Foundation</a>) </div> <article class='h-entry'> <h1 class='p-name'>Microformats are amazing</h1> <p>Published by <a class='p-author h-card' href='http://example.com'>W. Developer</a> on <time class='dt-published' datetime='2013-06-13 12:00:00'>13<sup>th</sup> June 2013</time> <p class='p-summary'>In which I extoll the virtues of using microformats.</p> <div class='e-content'> <p>Blah blah blah</p> </div> </article> <span class='h-cite'> <time class='dt-published'>YYYY-MM-DD</time> <span class='p-author h-card'>AUTHOR</span>: <cite><a class='u-url p-name' href='URL'>TITLE</a></cite> </span> </body>" -homePage ∷ TL.Text → Html → Html-homePage v result = docTypeHtml $ do+homePage ∷ TL.Text → Html+homePage v = docTypeHtml $ do H.head $ do H.meta ! charset "utf-8" H.title "microformats2-parser"- H.style "body { font-family: 'Helvetica Neue', sans-serif; max-width: 900px; margin: 0 auto; } a { color: #ba2323; } a:hover { color: #da4343; } pre, textarea, button { width: 100%; } textarea { resize: vertical; min-height: 10em; margin-bottom: 1em; } pre { white-space: pre-wrap; } footer { margin: 2em 0; }"+ H.style "body { font-family: 'Helvetica Neue', sans-serif; max-width: 900px; margin: 0 auto; } a { color: #ba2323; } a:hover { color: #da4343; } pre, input, textarea, button { width: 100%; } input, textarea { margin-bottom: 1em; } textarea { resize: vertical; min-height: 15em; } pre { white-space: pre-wrap; } footer { margin: 2em 0; }" H.body $ do- h1 $ do- a ! href "https://github.com/myfreeweb/microformats2-parser" $ "microformats2-parser"+ H.header $ do+ h1 $ do+ a ! href "https://github.com/myfreeweb/microformats2-parser" $ "microformats2-parser"+ a ! href "https://github.com/myfreeweb/microformats2-parser" $ img ! alt "GitHub" ! src "https://img.shields.io/badge/git-hub-gray.svg?style=flat"+ " "+ a ! href "https://hackage.haskell.org/package/microformats2-parser" $ img ! alt "Hackage" ! src "https://img.shields.io/hackage/v/microformats2-parser.svg?style=flat"+ " "+ a ! href "https://travis-ci.org/myfreeweb/microformats2-parser" $ img ! alt "Build Status" ! src "https://img.shields.io/travis/myfreeweb/microformats2-parser.svg?style=flat"+ " "+ a ! href "http://unlicense.org" $ img ! alt "unlicense" ! src "https://img.shields.io/badge/un-license-green.svg?style=flat" p "This is a test page for the Microformats 2 Haskell parser."- p "Note:"+ p "Notes:" ul $ do- li "this demo page uses the Sanitize mode for e-content in h-cite and h-entry"- H.form ! method "post" ! action "" $ do+ li "this demo page uses the Sanitize mode for e-*"+ li $ do+ a ! href "http://enable-cors.org" $ "CORS is enabled"+ " on the endpoint (POST parse.json, form-urlencoded, 'html' and 'base' parameter)"+ li $ a ! href "http://jsonview.com" $ "JSONView is awesome"+ H.form ! method "post" ! action "parse.json" $ do textarea ! name "html" $ toHtml v+ input ! name "base" ! type_ "url" ! placeholder "https://example.com/base/url/for/resolving/relative/urls" button "Parse!"- result footer $ do- a ! href "https://unrelenting.technology" $ "unrelenting.technology"--display ∷ Show α ⇒ α → Html-display = pre . toHtml . S.toLazyText . show--parseResult ∷ TL.Text → Html-parseResult h = section $ do- let root = documentRoot $ parseLBS $ S.toLazyByteString h- h2 "h-geo"- display $ parseGeo root- h2 "h-adr"- display $ parseAdr root- h2 "h-card"- display $ parseCard root- h2 "h-cite"- display $ parseCite Sanitize root- h2 "h-entry"- display $ parseEntry Sanitize root+ a ! href "https://unrelenting.technology" ! rel "author" $ "unrelenting.technology" app = scottyApp $ do- matchAny "/" $ do- ps ← params- let h' = lookup "html" ps- result = case h' of- Just h → parseResult h- Nothing → toHtml ("" ∷ TL.Text)+ middleware autohead++ get "/" $ do setHeader "Content-Type" "text/html; charset=utf-8"- raw $ renderHtml $ homePage (fromMaybe exampleValue h') result+ raw $ renderHtml $ homePage exampleValue++ get "/parse.json" $ do+ setHeader "Access-Control-Allow-Origin" "*"+ json $ object []++ post "/parse.json" $ do+ html ← param "html"+ base ← param "base" `rescue` (\_ → return "")+ setHeader "Content-Type" "application/json; charset=utf-8"+ setHeader "Access-Control-Allow-Origin" "*"+ let root = documentRoot $ parseLBS html+ raw $ encodePretty $ parseMf2 (def { baseUri = parseURI base }) root main = O.runCommand $ \opts args → do let warpSettings = setPort (port opts) defaultSettings
library/Data/Microformats2/Parser.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE UnicodeSyntax, OverloadedStrings, CPP #-} module Data.Microformats2.Parser (- module Data.Microformats2.Parser+ Mf2ParserSettings (..)+, HtmlContentMode (..)+, parseMf2 -- * HTML parsing stuff (from html-conduit, xml-lens) , documentRoot@@ -9,164 +11,129 @@ , sinkDoc ) where +import Text.HTML.DOM+import Text.XML.Lens hiding ((.=)) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif-import Control.Monad-import Data.Microformats2-import Data.Microformats2.Parser.Internal+import Data.Microformats2.Parser.Property+import Data.Microformats2.Parser.HtmlUtil+import Data.Microformats2.Parser.Util import Data.Default--- import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import Text.HTML.DOM-import Text.XML.Lens--data HtmlContentMode = Unsafe | Strip | Escape | Sanitize--(.&&.) ∷ Monad μ ⇒ μ Bool → μ Bool → μ Bool-(.&&.) = liftM2 (&&)--findMicroformat ∷ String → Element → [Element]-findMicroformat n e = e ^.. entire . hasClass n---- | Parses all h-geo entries inside of an element.-parseGeo ∷ Element → [Geo]-parseGeo = map extractGeo . findGeo---- | Finds all h-geo elements inside of an element.-findGeo ∷ Element → [Element]-findGeo = findMicroformat "h-geo"---- | Parses an element as h-geo.-extractGeo ∷ Element → Geo-extractGeo e = def { geoLatitude = extractPropertyR P "latitude" e- , geoLongitude = extractPropertyR P "longitude" e- , geoAltitude = extractPropertyR P "altitude" e }----- | Parses all h-adr entries inside of an element.-parseAdr ∷ Element → [Adr]-parseAdr = map extractAdr . findAdr---- | Finds all h-adr elements inside of an element.-findAdr ∷ Element → [Element]-findAdr = findMicroformat "h-adr"+import Data.Aeson+import Data.Aeson.Types+import Data.Aeson.Lens+import Data.Char (isSpace)+import qualified Data.HashMap.Strict as HMS+import qualified Data.Vector as V+import Data.Maybe+import qualified Data.Text as T+import Network.URI+import Safe (headMay) --- | Parses an element as h-adr.-extractAdr ∷ Element → Adr-extractAdr e = def { adrStreetAddress = extractPropertyL P "street-address" e- , adrExtendedAddress = extractPropertyL P "extended-address" e- , adrPostOfficeBox = extractPropertyL P "post-office-box" e- , adrLocality = extractPropertyL P "locality" e- , adrRegion = extractPropertyL P "region" e- , adrPostalCode = extractPropertyL P "postal-code" e- , adrCountryName = extractPropertyL P "country-name" e- , adrLabel = extractPropertyL P "label" e- , adrGeo = filter (/= GeoGeo def) $- (GeoGeo . extractGeo $ e) :- (TextGeo <$> extractPropertyL P "geo" e)- ++ (GeoGeo . extractGeo <$> findPropertyMicroformat e "p-geo" "h-geo") }+data Mf2ParserSettings = Mf2ParserSettings+ { htmlMode ∷ HtmlContentMode+ , baseUri ∷ Maybe URI }+ deriving (Show, Eq) +instance Default Mf2ParserSettings where+ def = Mf2ParserSettings { htmlMode = Sanitize+ , baseUri = Nothing } --- | Parses all h-card entries inside of an element.-parseCard ∷ Element → [Card]-parseCard = map extractCard . findCard+mf2Elements ∷ Traversal' Element Element+mf2Elements = attributeSatisfies "class" $ any isMf2Class . T.split isSpace --- | Finds all h-card elements inside of an element.-findCard ∷ Element → [Element]-findCard = findMicroformat "h-card"+readPropertyName ∷ T.Text → (T.Text, T.Text)+readPropertyName x = (fromMaybe "p" $ headMay ps, T.intercalate "-" $ drop 1 ps)+ where ps = T.splitOn "-" x --- | Parses an element as h-card.-extractCard ∷ Element → Card-extractCard e = def { cardName = extractPropertyL P "name" e- , cardHonorificPrefix = extractPropertyL P "honorific-prefix" e- , cardGivenName = extractPropertyL P "given-name" e- , cardAdditionalName = extractPropertyL P "additional-name" e- , cardFamilyName = extractPropertyL P "family-name" e- , cardSortString = extractPropertyL P "sort-string" e- , cardHonorificSuffix = extractPropertyL P "honorific-suffix" e- , cardNickname = extractPropertyL P "nickname" e- , cardEmail = extractPropertyL U "email" e- , cardLogo = extractPropertyL U "logo" e- , cardPhoto = extractPropertyL U "photo" e- , cardUrl = extractPropertyL U "url" e- , cardUid = extractPropertyL U "uid" e- , cardCategory = extractPropertyL P "category" e- , cardAdr = filter (/= AdrAdr def) $- (AdrAdr . extractAdr $ e) :- (TextAdr <$> extractPropertyL P "adr" e)- ++ ((AdrAdr . extractAdr) <$> findPropertyMicroformat e "p-adr" "h-adr")- , cardTel = extractPropertyL P "tel" e- , cardNote = extractPropertyL P "note" e- , cardBday = extractPropertyDt "bday" e- , cardKey = extractPropertyL U "key" e- , cardOrg = filter (/= CardCard def) $- (TextCard <$> extractPropertyL P "org" e)- ++ ((CardCard . extractCard) <$> findPropertyMicroformat e "p-org" "h-card")- , cardJobTitle = extractPropertyL P "job-title" e- , cardRole = extractPropertyL P "role" e- , cardImpp = extractPropertyL U "impp" e- , cardSex = extractPropertyL P "sex" e- , cardGenderIdentity = extractPropertyL P "gender-identity" e- , cardAnniversary = extractPropertyDt "anniversary" e }+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 (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 _ _ _ = Null +-- lens-aeson's 'key' doesn't add new keys :-( --- | Parses all h-cite entries inside of an element.-parseCite ∷ HtmlContentMode → Element → [Cite]-parseCite m = map (extractCite m) . findCite+addValue ∷ T.Text → Value → Value → Value+addValue "p" v@(Object o) f = Object $ HMS.insert "value" (fromMaybe f $ v ^? key "properties" . key "name" . nth 0) o+addValue "e" (Object o) f = Object $ HMS.insert "value" (fromMaybe Null $ f ^? key "value") $ HMS.insert "html" (fromMaybe Null $ f ^? key "html") o+addValue "u" v@(Object o) f = Object $ HMS.insert "value" (fromMaybe f $ v ^? key "properties" . key "url" . nth 0) o+addValue _ (Object o) f = Object $ HMS.insert "value" f o+addValue _ x _ = x --- | Finds all h-cite elements inside of an element.-findCite ∷ Element → [Element]-findCite = findMicroformat "h-cite"+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+ where addIfNull nameJ nameH f obj = if null $ 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+addImpliedProperties _ _ v = v --- | Parses an element as h-cite.-extractCite ∷ HtmlContentMode → Element → Cite-extractCite m e = def { citeName = extractPropertyL P "name" e- , citePublished = extractPropertyDt "published" e- , citeAuthor = filter (/= CardCard def) $- (TextCard <$> extractPropertyL P "author" e)- ++ (CardCard . extractCard <$> findPropertyMicroformat e "p-author" "h-card")- , citeUrl = extractPropertyL U "url" e- , citeUid = extractPropertyL U "uid" e- , citePublication = extractPropertyL P "publication" e- , citeAccessed = extractPropertyDt "accessed" e- , citeContent = TextContent <$> processContent m e }+removePropertiesOfNestedMicroformats ∷ [Element] → [Element] → [Element]+removePropertiesOfNestedMicroformats nmf2s = filter (not . isNested)+ where isNested e = any (\e' → e `elem` filter (/= e') (e' ^.. entire)) nmf2s +parseProperty ∷ Mf2ParserSettings → Element → [Pair]+parseProperty settings e =+ let propNames = groupBy' snd $ map readPropertyName $ filter isPropertyClass $ classes e+ extractPropertyValue (t, _) = extractProperty settings t e in+ if any isMf2Class $ classes e+ then map (\(n, ts) → n .= [ addValue (fst $ head ts) (parseH settings e) (extractPropertyValue $ head ts) ]) propNames+ else map (\(n, ts) → n .= map extractPropertyValue ts) propNames --- | Parses all h-entry entries inside of an element.-parseEntry ∷ HtmlContentMode → Element → [Entry]-parseEntry m = map (extractEntry m) . findEntry+parseH ∷ Mf2ParserSettings → Element → Value+parseH settings e =+ object $ filter (\(n, v) → not (emptyVal v) || n == "properties") [+ "type" .= filter isMf2Class (classes e)+ , "properties" .= properties+ , "children" .= childrenMf2+ , "shape" .= fromMaybe Null (String <$> e ^. el "area" . attribute "shape")+ , "coords" .= fromMaybe Null (String <$> e ^. el "area" . attribute "coords") ]+ where childrenMf2 = map ((\x → addValue "p" x Null) . parseH settings) $ filter (not . isProperty) $ deduplicateElements allMf2Descendants+ allMf2Descendants = filter (/= e) $ e ^.. entire . mf2Elements+ -- we have to do all of this because multiple elements can become multiple properties (with overlap)+ properties = Object $ HMS.filter (not . emptyVal) properties'+ (Object properties') = addImpliedProperties settings e $ object $ map mergeProps $ groupBy' fst properties''+ properties'' = concatMap (parseProperty settings) $ removePropertiesOfNestedMicroformats allMf2Descendants $ filter (/= e) $ e ^.. entire . propertyElements+ mergeProps (n, vs) = (n, Array $ V.concat $ reverse $ map (extractVector . snd) vs)+ extractVector (Array v) = v+ extractVector _ = V.empty --- | Finds all h-entry elements inside of an element.-findEntry ∷ Element → [Element]-findEntry = findMicroformat "h-entry"+-- | Parses Microformats 2 from an HTML Element into a JSON Value.+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+ relUrls = object $ map relUrlObject linkEls+ relUrlObject e = resolveUrl 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+ , linkAttr "media" "media" e+ , linkAttr "hreflang" "hreflang" e ])+ linkAttr nameJ nameH e = nameJ .= fromMaybe Null (String <$> e ^. attribute nameH)+ linkEls = filter (not . null . (^. attribute "href")) $ filter (not . null . (^. attribute "rel")) $ rootEl' ^.. entire . els [ "a", "link" ]+ -- Obligatory WTF comment about base[href] being relative to the URI the page was requested from! <https://developer.mozilla.org/en-US/docs/Web/HTML/Element/base>+ settings' = settings { baseUri = case (baseUri settings, parseURIReference =<< T.unpack <$> (rootEl' ^. entire . el "base" . attribute "href")) of+ (Just sU, Just tU) → Just (tU `relativeTo` sU)+ (Just sU, Nothing) → Just sU+ (Nothing, Just tU) → Just tU+ (Nothing, Nothing) → Nothing }+ rootEl' = preprocessHtml rootEl --- | Parses an element as h-entry.-extractEntry ∷ HtmlContentMode → Element → Entry-extractEntry m e = def { entryName = extractPropertyL P "name" e- , entrySummary = extractPropertyL P "summary" e- , entryContent = TextContent <$> processContent m e - , entryPublished = extractPropertyDt "published" e- , entryUpdated = extractPropertyDt "updated" e- , entryAuthor = filter (/= CardCard def) $- (TextCard <$> extractPropertyL P "author" e)- ++ (CardCard . extractCard <$> findPropertyMicroformat e "p-author" "h-card")- , entryCategory = extractPropertyL P "category" e- , entryUrl = extractPropertyL U "url" e- , entryUid = extractPropertyL U "uid" e- , entryLocation = filter ((/= CardLoc def) .&&. (/= AdrLoc def) .&&. (/= GeoLoc def)) $- (CardLoc . extractCard <$> findPropertyMicroformat e "p-location" "h-card")- ++ (AdrLoc . extractAdr <$> findPropertyMicroformat e "p-location" "h-adr")- ++ (GeoLoc . extractGeo <$> findPropertyMicroformat e "p-location" "h-geo")- , entryComments = filter (/= CiteEntry def) $- (CiteEntry . extractCite m <$> findPropertyMicroformat e "p-comment" "h-cite")- , entrySyndication = extractPropertyL U "syndication" e- , entryInReplyTo = UrlEntry <$> extractPropertyL U "in-reply-to" e- , entryLikeOf = UrlEntry <$> extractPropertyL U "like-of" e- , entryRepostOf = UrlEntry <$> extractPropertyL U "repost-of" e }+resolveUrl ∷ Mf2ParserSettings → T.Text → T.Text+resolveUrl settings t = case parseURIReference $ T.unpack t of+ Just u → T.pack $ uriToString id (u `relativeTo` fromMaybe nullURI (baseUri settings)) ""+ Nothing → t -processContent ∷ HtmlContentMode → Element → [LT.Text]-processContent Unsafe = extractPropertyContent getAllHtml E "content"-processContent Strip = extractPropertyContent getAllText E "content"-processContent Escape = map (LT.replace "<" "<" . LT.replace ">" ">" . LT.replace "&" "&") . extractPropertyContent getAllHtml E "content"-processContent Sanitize = extractPropertyContent getAllHtmlSanitized E "content"+preprocessHtml ∷ Element → Element+preprocessHtml (Element n as ns) = Element (lowerName n) as $ map preprocessChildren $ filter (not . isTemplate) ns+ where isTemplate (NodeElement (Element (Name "template" _ _) _ _)) = True+ isTemplate _ = False+ preprocessChildren (NodeElement e) = NodeElement $ preprocessHtml e+ preprocessChildren x = x+ lowerName (Name txt x y) = Name (T.toLower txt) x y
+ library/Data/Microformats2/Parser/HtmlUtil.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-}+{-# LANGUAGE CPP, RankNTypes #-}++module Data.Microformats2.Parser.HtmlUtil (+ HtmlContentMode (..)+, getInnerHtml+, getInnerHtmlSanitized+, getInnerTextRaw+, getInnerTextWithImgs+, getProcessedInnerHtml+, deduplicateElements+) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif+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.Foldable (asum)+import Data.Maybe+import Text.Blaze+import Text.Blaze.Renderer.Text+import Text.HTML.SanitizeXSS+import Text.XML.Lens hiding (re)+import Data.Microformats2.Parser.Util++getPrism ∷ Prism' Node Text → Element → Maybe Text+getPrism t e = Just . T.strip <$> T.concat $ e ^.. nodes . traverse . t++_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++getInnerHtml ∷ Element → Maybe Text+getInnerHtml = getPrism _InnerHtml++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 → 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++getInnerTextRaw ∷ Element → Maybe Text+getInnerTextRaw e = unless' (txt == Just "") txt+ where txt = getPrism _InnerTextRaw e++getInnerTextWithImgs ∷ Element → Maybe Text+getInnerTextWithImgs e = unless' (txt == Just "") txt+ where txt = getPrism _InnerTextWithImgs e++data HtmlContentMode = Unsafe | Escape | Sanitize+ deriving (Show, Eq)++getProcessedInnerHtml ∷ HtmlContentMode → Element → Maybe Text+getProcessedInnerHtml Unsafe e = getInnerHtml e+getProcessedInnerHtml Escape e = (T.replace "<" "<" . T.replace ">" ">" . T.replace "&" "&") <$> getInnerHtml e+getProcessedInnerHtml Sanitize e = getInnerHtmlSanitized 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...
− library/Data/Microformats2/Parser/Internal.hs
@@ -1,222 +0,0 @@-{-# LANGUAGE OverloadedStrings, QuasiQuotes, UnicodeSyntax #-}-{-# LANGUAGE CPP, RankNTypes #-}--module Data.Microformats2.Parser.Internal where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Control.Monad (liftM)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Text (Text)-import Data.Foldable (asum)-import qualified Data.Set as S-import qualified Data.Map as M-import Data.Maybe-import Data.Time.Format-import Text.XML.Lens hiding (re)-import Text.HTML.SanitizeXSS-import Text.Blaze-import Text.Blaze.Renderer.Text-import Text.Regex.PCRE.Heavy-import Safe (readMay)--if' ∷ Bool → Maybe a → Maybe a-if' c x = if c then x else Nothing--entireNotMicroformat ∷ Traversal' Element Element-entireNotMicroformat f e@(Element _ _ ns) = com <$> f e <*> traverse (_Element (entireNotMicroformat f)) (filter notMf ns)- where com (Element n a _) = Element n a- notMf (NodeElement (Element _ a _)) = not $ (fromMaybe "" $ lookup "class" $ map unwrapName $ M.toList a) ≈ [re|h-\w+|]- notMf _ = True- unwrapName (Name n _ _, val) = (n, val)--hasOneClass ∷ [String] → Traversal' Element Element-hasOneClass ns = attributeSatisfies "class" $ \a → any (\x → T.isInfixOf (T.pack x) a) ns--hasClass ∷ String → Traversal' Element Element-hasClass n = attributeSatisfies "class" $ T.isInfixOf . T.pack $ n--getOnlyChildren ∷ Element → [Element]-getOnlyChildren e = if lengthOf plate e == 1 then e ^.. plate else []--getOnlyChild ∷ Name → Element → Maybe Element-getOnlyChild n e = if' (lengthOf plate e == 1) $ e ^? plate . el n--getOnlyOfType ∷ Name → Element → Maybe Element-getOnlyOfType n e = if' (lengthOf (plate . el n) e == 1) $ e ^? plate . el n--els ∷ [Name] → Traversal' Element Element-els ns f s = if elementName s `elem` ns then f s else pure s--removeWhitespace ∷ Text → Text-removeWhitespace = gsub [re|(\s+| )|] (" " ∷ String) -- lol vim |||||||--getPrism ∷ Prism' Node Text → Element → Maybe Text-getPrism t e = Just . T.strip <$> T.concat $ e ^.. nodes . traverse . t--_InnerHtml ∷ Prism' Node Text-_InnerHtml = prism' NodeContent $ \s → case s of- NodeContent c → Just $ removeWhitespace c- NodeElement e → Just . TL.toStrict . renderMarkup . toMarkup $ e- _ → Nothing--getAllHtml ∷ Element → Maybe Text-getAllHtml = getPrism _InnerHtml---- XXX: https://github.com/yesodweb/haskell-xss-sanitize/issues/11-safeTagName ∷ Text → Bool-safeTagName = (`S.member` S.fromList [ "a", "b", "abbr", "acronym", "br", "ul", "li", "ol", "span", "strong", "em",- "i", "q", "img", "time", "strike", "kbd", "dl", "dt", "pre", "p", "blockquote",- "code", "cite", "figure", "figcaption", "big", "dfn" ])--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 $ removeWhitespace c- NodeElement e → if not $ safeTagName $ nameLocalName (elementName e)- then Nothing- else Just . TL.toStrict . renderMarkup . toMarkup $ sanitizeAttrs e- _ → Nothing--getAllHtmlSanitized ∷ Element → Maybe Text-getAllHtmlSanitized = getPrism _InnerHtmlSanitized--_InnerText ∷ Prism' Node Text-_InnerText = prism' NodeContent $ \s → case s of- NodeContent c → Just $ removeWhitespace c- NodeElement e → if nameLocalName (elementName e) == "img"- then e ^. el "img" . attribute "alt"- else Just . removeWhitespace . TL.toStrict . renderMarkup . contents . toMarkup $ e- _ → Nothing--getAllText ∷ Element → Maybe Text-getAllText = getPrism _InnerText--getText ∷ Element → Maybe Text-getText e = if T.null $ fromMaybe "" txt then Nothing else txt- where txt = listToMaybe $ T.strip <$> e ^.. entire . nodes . traverse . _Content--getAbbrTitle ∷ Element → Maybe Text-getAbbrTitle e = e ^. el "abbr" . attribute "title"--getDataInputValue ∷ Element → Maybe Text-getDataInputValue e = e ^. els ["data", "input"] . attribute "value"--getImgSrc ∷ Element → Maybe Text-getImgSrc e = e ^. el "img" . attribute "src"--getObjectData ∷ Element → Maybe Text-getObjectData e = e ^. el "object" . attribute "data"--getImgAreaAlt ∷ Element → Maybe Text-getImgAreaAlt e = e ^. els ["img", "area"] . attribute "alt"--getAAreaHref ∷ Element → Maybe Text-getAAreaHref e = e ^. els ["a", "area"] . attribute "href"--getImgAudioVideoSourceSrc ∷ Element → Maybe Text-getImgAudioVideoSourceSrc e = e ^. els ["img", "audio", "video", "source"] . attribute "src"--getTimeInsDelDatetime ∷ Element → Maybe Text-getTimeInsDelDatetime e = e ^. els ["time", "ins", "del"] . attribute "datetime"--getOnlyChildImgAreaAlt ∷ Element → Maybe Text-getOnlyChildImgAreaAlt e = (^. attribute "alt") =<< asum (getOnlyChild <$> [ "img", "area" ] <*> pure e)--getOnlyChildAbbrTitle ∷ Element → Maybe Text-getOnlyChildAbbrTitle e = (^. attribute "title") =<< getOnlyChild "abbr" e--getOnlyOfTypeImgSrc ∷ Element → Maybe Text-getOnlyOfTypeImgSrc e = (^. attribute "src") =<< getOnlyOfType "img" e--getOnlyOfTypeObjectData ∷ Element → Maybe Text-getOnlyOfTypeObjectData e = (^. attribute "data") =<< getOnlyOfType "object" e--getOnlyOfTypeAAreaHref ∷ Element → Maybe Text-getOnlyOfTypeAAreaHref e = (^. attribute "href") =<< asum (getOnlyOfType <$> [ "a", "area" ] <*> pure e)--extractValue ∷ Element → Maybe Text-extractValue e = asum $ [ getAbbrTitle, getDataInputValue, getImgAreaAlt, getAllText ] <*> pure e--extractValueTitle ∷ Element → Maybe Text-extractValueTitle e = if' (isJust $ e ^? hasClass "value-title") $ e ^. attribute "title"--extractValueClassPattern ∷ [Element → Maybe Text] → Element → Maybe Text-extractValueClassPattern fs e = if' (isJust $ e ^? valueParts) extractValueParts- where extractValueParts = Just . T.concat . catMaybes $ e ^.. valueParts . to extractValuePart- extractValuePart e' = asum $ fs <*> pure e'- valueParts ∷ Applicative f => (Element → f Element) → Element → f Element- valueParts = entire . hasOneClass ["value", "value-title"]--className ∷ PropType → String → String-className P n = "p-" ++ n-className U n = "u-" ++ n-className Dt n = "dt-" ++ n-className E n = "e-" ++ n--findProperty ∷ Element → String → [Element]-findProperty e n = filter (/= e) $ e ^.. entireNotMicroformat . hasClass n--findPropertyMicroformat ∷ Element → String → String → [Element]-findPropertyMicroformat e n s = filter (/= e) $ e ^.. entire . hasClass n . hasClass s--data PropType = P | U | Dt | E--extract ∷ [Element → Maybe Text] → Element → [Text]-extract ps e = catMaybes $ [ \x -> asum $ ps <*> pure x ] <*> pure e--extractProperty ∷ PropType → String → Element → [Text]-extractProperty P n e' =- findProperty e' (className P n) >>=- extract [ extractValueClassPattern [extractValueTitle, extractValue]- , extractValue ]-extractProperty U n e' =- findProperty e' (className U n) >>=- extract [ getAAreaHref, getImgAudioVideoSourceSrc- , extractValueClassPattern [extractValueTitle, extractValue]- , getAbbrTitle, getDataInputValue, getAllText ]-extractProperty Dt n e' =- findProperty e' (className Dt n) >>=- extract (extractValueClassPattern ms : ms ++ [getAllText])- where ms = [ getTimeInsDelDatetime, getAbbrTitle, getDataInputValue ]-extractProperty E n e' = findProperty e' (className E n) >>= liftM maybeToList getAllHtml--extractPropertyL ∷ PropType → String → Element → [TL.Text]-extractPropertyL t n e = TL.fromStrict <$> if null extracted then maybeToList $ implyProperty t n e else extracted- where extracted = extractProperty t n e--extractPropertyR ∷ Read α ⇒ PropType → String → Element → [α]-extractPropertyR t n e = catMaybes $ readMay <$> T.unpack <$> extractProperty t n e--extractPropertyDt ∷ ParseTime α ⇒ String → Element → [α]-extractPropertyDt n e = catMaybes $ readISO <$> T.unpack <$> extractProperty Dt n e- where readISO x = asum $ map ($ x) [ isoParse $ Just "%H:%M:%S%z"- , isoParse $ Just "%H:%M:%SZ"- , isoParse $ Just "%H:%M:%S"- , isoParse $ Just "%H:%M"- , parseTimeD "%G-W%V-%u"- , parseTimeD "%G-W%V"- , isoParse Nothing ]- isoParse = parseTimeD . iso8601DateFormat- parseTimeD = parseTimeM True defaultTimeLocale --extractPropertyContent ∷ (Element → Maybe Text) → PropType → String → Element → [TL.Text]-extractPropertyContent ex t n e = findProperty e (className t n) >>= extract [ ex ] >>= return . TL.fromStrict--implyProperty ∷ PropType → String → Element → Maybe Text-implyProperty P "name" e = asum $ [ getImgAreaAlt, getAbbrTitle- , getOnlyChildImgAreaAlt, getOnlyChildAbbrTitle- , \e' -> asum $ [ getOnlyChildImgAreaAlt, getOnlyChildAbbrTitle ] <*> getOnlyChildren e'- , getText ] <*> pure e-implyProperty U "photo" e = asum $ [ getImgSrc, getObjectData- , getOnlyOfTypeImgSrc, getOnlyOfTypeObjectData- , \e' -> asum $ [ getOnlyOfTypeImgSrc, getOnlyOfTypeObjectData ] <*> getOnlyChildren e'- ] <*> pure e-implyProperty U "url" e = asum $ [ getAAreaHref, getOnlyOfTypeAAreaHref ] <*> pure e-implyProperty _ _ _ = Nothing
+ library/Data/Microformats2/Parser/Property.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes, UnicodeSyntax #-}+{-# LANGUAGE CPP, RankNTypes, TupleSections #-}++module Data.Microformats2.Parser.Property where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif+import qualified Data.Text as T+import Data.Text (Text)+import Data.Char (isSpace)+import Data.Foldable (asum)+import qualified Data.Map as M+import Data.Maybe+import Text.XML.Lens hiding (re)+import Data.Microformats2.Parser.HtmlUtil+import Data.Microformats2.Parser.Util++unwrapName ∷ (Name, a) → (Text, a)+unwrapName (Name n _ _, val) = (n, val)++classes ∷ Element → [Text]+classes (Element _ as _) = T.split isSpace . fromMaybe "" . lookup "class" . map unwrapName . M.toList $ as++isPClass, isUClass, isEClass, isDtClass, isPropertyClass, isMf2Class ∷ Text → Bool+isPClass = T.isPrefixOf "p-"+isUClass = T.isPrefixOf "u-"+isEClass = T.isPrefixOf "e-"+isDtClass = T.isPrefixOf "dt-"+isPropertyClass x = isPClass x || isUClass x || isEClass x || isDtClass x+isMf2Class = T.isPrefixOf "h-"++isProperty ∷ Element → Bool+isProperty = any isPropertyClass . classes++propertyElements ∷ Traversal' Element Element+propertyElements = attributeSatisfies "class" $ any isPropertyClass . T.split isSpace++hasOneClass ∷ [String] → Traversal' Element Element+hasOneClass ns = attributeSatisfies "class" $ \a → any (\x → (T.pack x) `elem` (T.split isSpace a)) ns++hasClass ∷ String → Traversal' Element Element+hasClass n = attributeSatisfies "class" $ \a → (T.pack n) `elem` (T.split isSpace a)++getOnlyChildren ∷ Element → [Element]+getOnlyChildren e = if lengthOf plate e == 1 then e ^.. plate else []++getOnlyChild, getOnlyOfType ∷ Name → Element → Maybe Element+getOnlyChild n e = if' (fromMaybe False $ not <$> isProperty <$> r) $ r+ where r = if' (lengthOf plate e == 1) $ e ^? plate . el n+getOnlyOfType n e = if' (fromMaybe False $ not <$> isProperty <$> r) $ r+ where r = if' (lengthOf (plate . el n) e == 1) $ e ^? plate . el n++els ∷ [Name] → Traversal' Element Element+els ns f s = if elementName s `elem` ns then f s else pure s++getAbbrTitle, getDataInputValue, getImgSrc, getObjectData, getImgAreaAlt, getAAreaHref, getImgAudioVideoSourceSrc, getTimeInsDelDatetime, getOnlyChildImgAreaAlt, \+getOnlyChildAbbrTitle, getOnlyOfTypeImgSrc, getOnlyOfTypeObjectData, getOnlyOfTypeAAreaHref, extractValue, extractValueTitle ∷ Element → Maybe Text+getAbbrTitle e = e ^. el "abbr" . attribute "title"+getDataInputValue e = e ^. els ["data", "input"] . attribute "value"+getImgSrc e = e ^. el "img" . attribute "src"+getObjectData e = e ^. el "object" . attribute "data"+getImgAreaAlt e = e ^. els ["img", "area"] . attribute "alt"+getAAreaHref e = e ^. els ["a", "area"] . attribute "href"+getImgAudioVideoSourceSrc e = e ^. els ["img", "audio", "video", "source"] . attribute "src"+getTimeInsDelDatetime e = e ^. els ["time", "ins", "del"] . attribute "datetime"+getOnlyChildImgAreaAlt e = (^. attribute "alt") =<< asum (getOnlyChild <$> [ "img", "area" ] <*> pure e)+getOnlyChildAbbrTitle e = (^. attribute "title") =<< getOnlyChild "abbr" e+getOnlyOfTypeImgSrc e = (^. attribute "src") =<< getOnlyOfType "img" e+getOnlyOfTypeObjectData e = (^. attribute "data") =<< getOnlyOfType "object" e+getOnlyOfTypeAAreaHref e = (^. attribute "href") =<< asum (getOnlyOfType <$> [ "a", "area" ] <*> pure e)+extractValue e = asum $ [ getAbbrTitle, getDataInputValue, getImgAreaAlt, getInnerTextRaw ] <*> pure e+extractValueTitle e = if' (isJust $ e ^? hasClass "value-title") $ e ^. attribute "title"++extractValueClassPattern ∷ [Element → Maybe Text] → Element → Maybe Text+extractValueClassPattern fs e = if' (isJust $ e ^? valueParts) extractValueParts+ where extractValueParts = Just . T.concat . catMaybes $ e ^.. valueParts . to extractValuePart+ extractValuePart e' = asum $ fs <*> pure e'+ valueParts ∷ Applicative f => (Element → f Element) → Element → f Element+ valueParts = entire . hasOneClass ["value", "value-title"]++extractP ∷ Element → Maybe Text+extractP e =+ asum $ [ extractValueClassPattern [extractValueTitle, extractValue]+ , getAbbrTitle, getDataInputValue, getImgAreaAlt, getInnerTextWithImgs ] <*> pure e++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 =+ asum $ [ (, True) <$> getAAreaHref e+ , (, True) <$> getImgAudioVideoSourceSrc e+ , (, True) <$> getObjectData e+ , (, False) <$> extractValueClassPattern [extractValueTitle, extractValue] e+ , (, False) <$> getAbbrTitle e+ , (, False) <$> getDataInputValue e+ , (, False) <$> getInnerTextRaw e ]++extractDt ∷ Element → Maybe Text+extractDt e =+ asum $ (extractValueClassPattern ms : ms ++ [getInnerTextRaw]) <*> pure e+ where ms = [ getTimeInsDelDatetime, getAbbrTitle, getDataInputValue ]++implyProperty ∷ String → Element → Maybe Text+implyProperty "name" e = asum $ [ getImgAreaAlt, getAbbrTitle+ , getOnlyChildImgAreaAlt, getOnlyChildAbbrTitle+ , \e' -> asum $ [ getOnlyChildImgAreaAlt, getOnlyChildAbbrTitle ] <*> getOnlyChildren e'+ , getInnerTextRaw ] <*> pure e+implyProperty "photo" e = asum $ [ getImgSrc, getObjectData+ , getOnlyOfTypeImgSrc, getOnlyOfTypeObjectData+ , \e' -> asum $ [ getOnlyOfTypeImgSrc, getOnlyOfTypeObjectData ] <*> getOnlyChildren e'+ ] <*> pure e+implyProperty "url" e = asum $ [ getAAreaHref, getOnlyOfTypeAAreaHref ] <*> pure e+implyProperty _ _ = Nothing
+ library/Data/Microformats2/Parser/Util.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes, UnicodeSyntax #-}+{-# LANGUAGE CPP, TupleSections #-}++module Data.Microformats2.Parser.Util where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif+import Data.Aeson+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 Text.Regex.PCRE.Heavy++if' ∷ Bool → Maybe a → Maybe a+if' c x = if c then x else Nothing++unless' ∷ Bool → Maybe a → Maybe a+unless' c x = if c then Nothing else x++listToMaybeList ∷ [α] → Maybe [α]+listToMaybeList l = unless' (null l) $ Just l++stripQueryString ∷ TL.Text → TL.Text+stripQueryString = TL.intercalate "" . take 1 . TL.splitOn "?" . TL.strip++collapseWhitespace ∷ T.Text → T.Text+collapseWhitespace = gsub [re|(\s+| )|] (" " ∷ String)++emptyVal ∷ Value → Bool+emptyVal (Object o) = HMS.null o+emptyVal (Array v) = V.null v+emptyVal (String s) = T.null s+emptyVal Null = True+emptyVal _ = False++groupBy' ∷ (Ord β) ⇒ (α → β) → [α] → [(β, [α])]+groupBy' f = M.toAscList . M.fromListWith (++) . map (\a → (f a, [a]))++-- https://hackage.haskell.org/package/liquid-fixpoint-0.4.0.0/docs/src/Language-Fixpoint-Misc.html#expandSnd+expandSnd ∷ Foldable φ ⇒ φ ([α], β) → [(α, β)]+expandSnd = F.concatMap (\(xs, y) → (, y) <$> xs)
microformats2-parser.cabal view
@@ -1,5 +1,5 @@ name: microformats2-parser-version: 0.1.1+version: 1.0.0 synopsis: A Microformats 2 parser. category: Web homepage: https://github.com/myfreeweb/microformats2-parser@@ -22,22 +22,31 @@ library build-depends: base >= 4.0.0.0 && < 5+ , transformers , text+ , bytestring , time , either , safe , containers+ , unordered-containers+ , vector+ , aeson+ , aeson-qq+ , lens-aeson , data-default- , microformats2-types , html-conduit , xml-lens+ , network-uri , blaze-markup , xss-sanitize , pcre-heavy default-language: Haskell2010 exposed-modules: Data.Microformats2.Parser- Data.Microformats2.Parser.Internal+ Data.Microformats2.Parser.Property+ Data.Microformats2.Parser.HtmlUtil+ Data.Microformats2.Parser.Util ghc-options: -Wall hs-source-dirs: library @@ -48,14 +57,17 @@ , warp , wai-extra , network+ , network-uri , streaming-commons , stringable+ , data-default , text , scotty+ , aeson+ , aeson-pretty , blaze-html , blaze-markup , microformats2-parser- , microformats2-types default-language: Haskell2010 ghc-prof-options: -auto-all -prof ghc-options: -threaded -rtsopts -with-rtsopts=-N@@ -65,12 +77,17 @@ test-suite tests build-depends: base >= 4.0.0.0 && < 5+ , mtl , time+ , text+ , bytestring+ , network-uri , hspec+ , hspec-expectations-pretty-diff , template-haskell , microformats2-parser- , microformats2-types , raw-strings-qq+ , aeson-qq , data-default , html-conduit , xml-lens@@ -80,5 +97,6 @@ main-is: Spec.hs other-modules: Data.Microformats2.ParserSpec- Data.Microformats2.Parser.InternalSpec+ Data.Microformats2.Parser.PropertySpec+ Data.Microformats2.Parser.HtmlUtilSpec type: exitcode-stdio-1.0
+ test-suite/Data/Microformats2/Parser/HtmlUtilSpec.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings, UnicodeSyntax, QuasiQuotes #-}++module Data.Microformats2.Parser.HtmlUtilSpec (spec) where++import Test.Hspec+import TestCommon+import Data.Microformats2.Parser.HtmlUtil++spec ∷ Spec+spec = do+ describe "getInnerTextRaw" $ do+ 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."++ describe "getInnerTextWithImgs" $ do+ it "returns textContent with handling imgs" $ do+ let txtraw = getInnerTextWithImgs . documentRoot . parseLBS+ txtraw [xml|<div>This is <a href="">text content</a> <img src="/yo" alt="with an alt"> <img src="and-src">.+ </div>|] `shouldBe` Just "This is text content with an alt and-src."
− test-suite/Data/Microformats2/Parser/InternalSpec.hs
@@ -1,97 +0,0 @@-{-# LANGUAGE OverloadedStrings, UnicodeSyntax, QuasiQuotes, CPP #-}--module Data.Microformats2.Parser.InternalSpec (spec) where--import Test.Hspec-import TestCommon-import Text.HTML.DOM-import Text.XML.Lens (documentRoot)-import Data.Microformats2.Parser.Internal-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif--{-# ANN module ("HLint: ignore Redundant do"::String) #-}--spec ∷ Spec-spec = do- describe "extractProperty" $ do- it "parses p- properties" $ do- let nm = extractProperty P "name" . documentRoot . parseLBS- nm [xml|<div><span class="p-name">Hello Basic</span>|] `shouldBe` pure "Hello Basic"- nm [xml|<div><p><span class="p-name">Hello Nested</span>|] `shouldBe` pure "Hello Nested"- nm [xml|<div><abbr class="p-name" title="Hello Abbr">HA</abbr>|] `shouldBe` pure "Hello Abbr"- nm [xml|<div><abbr class="p-name">HA</abbr>|] `shouldBe` pure "HA"- nm [xml|<div><data class="p-name" value="Hello Data" />|] `shouldBe` pure "Hello Data"- nm [xml|<div><input class="p-name" value="Hello Input" />|] `shouldBe` pure "Hello Input"- nm [xml|<div><img class="p-name" alt="Hello Img" />|] `shouldBe` pure "Hello Img"- nm [xml|<div><area class="p-name" alt="Hello Area" />|] `shouldBe` pure "Hello Area"- nm [xml|<div><span class="p-name"> ignore <i class="value">Hello</i> <img class="value" alt="ValuePattern" src="x.png"> </span>|] `shouldBe` pure "HelloValuePattern"- nm [xml|<div><span class="p-name"> ignore <em class="value-title" title="Hello">Hi</em> <span class="value">Value-Title</span></span>|] `shouldBe` pure "HelloValue-Title"- nm [xml|<div><span class="p-name"> Hello <img alt="Span With Img" src="x.png"> </span>|] `shouldBe` pure "Hello Span With Img"- nm [xml|<div><span class="p-name"> <span class="value"> Hello - <img alt="Span With Img" src="x.png"> </span> <em class="value-title" title="&& Value Title">nope</em> </span>|] `shouldBe` pure "Hello Span With Img&& Value Title"-- it "parses u- properties" $ do- let ur = extractProperty U "url" . documentRoot . parseLBS- ur [xml|<div><a class="u-url" href="/yo/a">link</a>|] `shouldBe` pure "/yo/a"- ur [xml|<div><area class="u-url" href="/yo/area"/>|] `shouldBe` pure "/yo/area"- ur [xml|<div><img class="u-url" src="/yo/img"/>|] `shouldBe` pure "/yo/img"- ur [xml|<div><audio class="u-url" src="/yo/audio"/>|] `shouldBe` pure "/yo/audio"- ur [xml|<div><video class="u-url" src="/yo/video"/>|] `shouldBe` pure "/yo/video"- ur [xml|<div><source class="u-url" src="/yo/source"/>|] `shouldBe` pure "/yo/source"- ur [xml|<div><span class="u-url"><b class=value>/yo</b><em class="value">/vcp</span>|] `shouldBe` pure "/yo/vcp"- ur [xml|<div><abbr class="u-url" title="/yo/abbr"/>|] `shouldBe` pure "/yo/abbr"- ur [xml|<div><data class="u-url" value="/yo/data"/>|] `shouldBe` pure "/yo/data"- ur [xml|<div><input class="u-url" value="/yo/input"/>|] `shouldBe` pure "/yo/input"- ur [xml|<div><span class="u-url">/yo/span</span>|] `shouldBe` pure "/yo/span"-- it "parses dt- properties" $ do- let dt = extractProperty Dt "updated" . documentRoot . parseLBS- dt [xml|<div><time class="dt-updated" datetime="ti.me">someday</time>|] `shouldBe` pure "ti.me"- dt [xml|<div><ins class="dt-updated" datetime="i.ns">someday</ins>|] `shouldBe` pure "i.ns"- dt [xml|<div><del class="dt-updated" datetime="d.el">someday</del>|] `shouldBe` pure "d.el"- dt [xml|<div><abbr class="dt-updated" title="ab.br">AB</abbr>|] `shouldBe` pure "ab.br"- dt [xml|<div><data class="dt-updated" value="da.ta"/>|] `shouldBe` pure "da.ta"- dt [xml|<div><input class="dt-updated" value="i.np.ut"/>|] `shouldBe` pure "i.np.ut"- dt [xml|<div><span class="dt-updated">- <abbr class="value" title="vcp">VCP</abbr>- <time class="value" datetime="ti">TIME</time>- <ins class="value" datetime="me">lol</time>- </span>|] `shouldBe` pure "vcptime"- dt [xml|<div><span class="dt-updated">date</span>|] `shouldBe` pure "date"-- it "parses e- properties" $ do- let ct = extractProperty E "content" . documentRoot . parseLBS- ct [xml|<div><div class="e-content"><em>hello html</em>!</div>|] `shouldBe` pure "<em>hello html</em>!"-- describe "implyProperty" $ do- it "parses implied p-name" $ do- let nm = implyProperty P "name" . documentRoot . parseLBS- nm [xml|<img class="h-blah" alt="Hello Img!">|] `shouldBe` pure "Hello Img!"- nm [xml|<abbr class="h-blah" title="Hello Abbr!">HA</abbr>|] `shouldBe` pure "Hello Abbr!"- nm [xml|<p class="h-blah"><img alt="Hello Only Img!"></p>|] `shouldBe` pure "Hello Only Img!"- nm [xml|<p class="h-blah"><img alt="DOING"><img alt="IT"><img alt="WRONG">Goodbye Img!</p>|] `shouldBe` pure "Goodbye Img!"- nm [xml|<p class="h-blah"><abbr title="Hello Only Abbr!">HOA</abbr></p>|] `shouldBe` pure "Hello Only Abbr!"- nm [xml|<p class="h-blah"><abbr title="DOING"/><abbr title="IT"/><abbr title="WRONG"/>Goodbye Abbr!</p>|] `shouldBe` pure "Goodbye Abbr!"- nm [xml|<p class="h-blah"><em><img alt="Hello Only Nested Img!"></p>|] `shouldBe` pure "Hello Only Nested Img!"- nm [xml|<p class="h-blah"><em><img alt="DOING"><img alt="WRONG">Goodbye Nested Img!</p>|] `shouldBe` pure "Goodbye Nested Img!"- nm [xml|<p class="h-blah"><em><abbr title="Hello Only Nested Abbr!">HOA</abbr></p>|] `shouldBe` pure "Hello Only Nested Abbr!"- nm [xml|<p class="h-blah"><em><abbr title="DOING"/><abbr title="WRONG"/>Goodbye Nested Abbr!</p>|] `shouldBe` pure "Goodbye Nested Abbr!"- nm [xml|<p class="h-blah">Hello Text!</p>|] `shouldBe` pure "Hello Text!"-- it "parses implied u-photo" $ do- let ph = implyProperty U "photo" . documentRoot . parseLBS- ph [xml|<img class="h-blah" src="selfie.png">|] `shouldBe` pure "selfie.png"- ph [xml|<object class="h-blah" data="art.svg">|] `shouldBe` pure "art.svg"- ph [xml|<div class="h-blah"><img src="selfie.png"/><em>yo</em>|] `shouldBe` pure "selfie.png"- ph [xml|<div class="h-blah"><object data="art.svg"/><em>yo</em>|] `shouldBe` pure "art.svg"- ph [xml|<div class="h-blah"><p class="onlychild"><img src="selfie.png"/><em>yo</em>|] `shouldBe` pure "selfie.png"- ph [xml|<div class="h-blah"><p class="onlychild"><object data="art.svg"/><em>yo</em>|] `shouldBe` pure "art.svg"-- it "parses implied u-url" $ do- let ur = implyProperty U "url" . documentRoot . parseLBS- ur [xml|<a class="h-blah" href="/hello/a">|] `shouldBe` pure "/hello/a"- ur [xml|<area class="h-blah" href="/hello/area">|] `shouldBe` pure "/hello/area"- ur [xml|<div class="h-blah"><em>what</em><a href="/hello/n/a">|] `shouldBe` pure "/hello/n/a"- ur [xml|<div class="h-blah"><em>what</em><area href="/hello/n/area">|] `shouldBe` pure "/hello/n/area"
+ test-suite/Data/Microformats2/Parser/PropertySpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings, UnicodeSyntax, QuasiQuotes, CPP #-}++module Data.Microformats2.Parser.PropertySpec (spec) where++import Test.Hspec+import TestCommon+import Data.Microformats2.Parser.Property+#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif++{-# ANN module ("HLint: ignore Redundant do"::String) #-}++spec ∷ Spec+spec = do+ describe "extractProperty" $ do+ it "parses p- properties" $ do+ let nm = extractP . documentRoot . parseLBS+ nm [xml|<span class="p-name">Hello Basic</span>|] `shouldBe` pure "Hello Basic"+ nm [xml|<abbr class="p-name" title="Hello Abbr">HA</abbr>|] `shouldBe` pure "Hello Abbr"+ nm [xml|<abbr class="p-name">HA</abbr>|] `shouldBe` pure "HA"+ nm [xml|<data class="p-name" value="Hello Data" />|] `shouldBe` pure "Hello Data"+ nm [xml|<input class="p-name" value="Hello Input" />|] `shouldBe` pure "Hello Input"+ nm [xml|<img class="p-name" alt="Hello Img" />|] `shouldBe` pure "Hello Img"+ nm [xml|<area class="p-name" alt="Hello Area" />|] `shouldBe` pure "Hello Area"+ nm [xml|<span class="p-name"> ignore <i class="value">Hello</i> <img class="value" alt="ValuePattern" src="x.png"> </span>|] `shouldBe` pure "HelloValuePattern"+ nm [xml|<span class="p-name"> ignore <em class="value-title" title="Hello">Hi</em> <span class="value">Value-Title</span></span>|] `shouldBe` pure "HelloValue-Title"+ nm [xml|<span class="p-name"> Hello <img alt="Span With Img" src="x.png"> </span>|] `shouldBe` pure "Hello Span With Img"+ nm [xml|<span class="p-name"> Hello <img src="span-with.png"> </span>|] `shouldBe` pure "Hello span-with.png"+ nm [xml|<span class="p-name"> <span class="value"> Hello + <img alt="Span With Img" src="x.png"> </span> <em class="value-title" title="&& Value Title">nope</em> </span>|] `shouldBe` pure "Hello&& Value Title"++ it "parses u- properties" $ do+ let ur = extractU . documentRoot . parseLBS+ ur [xml|<a class="u-url" href="/yo/a">link</a>|] `shouldBe` pure ("/yo/a", True)+ ur [xml|<area class="u-url" href="/yo/area"/>|] `shouldBe` pure ("/yo/area", True)+ ur [xml|<img class="u-url" src="/yo/img"/>|] `shouldBe` pure ("/yo/img", True)+ ur [xml|<audio class="u-url" src="/yo/audio"/>|] `shouldBe` pure ("/yo/audio", True)+ ur [xml|<video class="u-url" src="/yo/video"/>|] `shouldBe` pure ("/yo/video", True)+ ur [xml|<source class="u-url" src="/yo/source"/>|] `shouldBe` pure ("/yo/source", True)+ ur [xml|<object class="u-url" data="/yo/data"/>|] `shouldBe` pure ("/yo/data", True)+ ur [xml|<span class="u-url"><b class=value>/yo</b><em class="value">/vcp</span>|] `shouldBe` pure ("/yo/vcp", False)+ ur [xml|<abbr class="u-url" title="/yo/abbr"/>|] `shouldBe` pure ("/yo/abbr", False)+ 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)++ it "parses dt- properties" $ do+ let dt = extractDt . documentRoot . parseLBS+ dt [xml|<time class="dt-updated" datetime="ti.me">someday</time>|] `shouldBe` pure "ti.me"+ dt [xml|<ins class="dt-updated" datetime="i.ns">someday</ins>|] `shouldBe` pure "i.ns"+ dt [xml|<del class="dt-updated" datetime="d.el">someday</del>|] `shouldBe` pure "d.el"+ dt [xml|<abbr class="dt-updated" title="ab.br">AB</abbr>|] `shouldBe` pure "ab.br"+ dt [xml|<data class="dt-updated" value="da.ta"/>|] `shouldBe` pure "da.ta"+ dt [xml|<input class="dt-updated" value="i.np.ut"/>|] `shouldBe` pure "i.np.ut"+ dt [xml|<span class="dt-updated">+ <abbr class="value" title="vcp">VCP</abbr>+ <time class="value" datetime="ti">TIME</time>+ <ins class="value" datetime="me">lol</time>+ </span>|] `shouldBe` pure "vcptime"+ dt [xml|<span class="dt-updated">date</span>|] `shouldBe` pure "date"++ describe "implyProperty" $ do+ it "parses implied p-name" $ do+ let nm = implyProperty "name" . documentRoot . parseLBS+ nm [xml|<img class="h-blah" alt="Hello Img!">|] `shouldBe` pure "Hello Img!"+ nm [xml|<abbr class="h-blah" title="Hello Abbr!">HA</abbr>|] `shouldBe` pure "Hello Abbr!"+ nm [xml|<p class="h-blah"><img alt="Hello Only Img!"></p>|] `shouldBe` pure "Hello Only Img!"+ nm [xml|<p class="h-blah"><img alt="DOING"><img alt="IT"><img alt="WRONG">Goodbye Img!</p>|] `shouldBe` pure "Goodbye Img!"+ nm [xml|<p class="h-blah"><abbr title="Hello Only Abbr!">HOA</abbr></p>|] `shouldBe` pure "Hello Only Abbr!"+ nm [xml|<p class="h-blah"><abbr title="DOING"/><abbr title="IT"/><abbr title="WRONG"/>Goodbye Abbr!</p>|] `shouldBe` pure "Goodbye Abbr!"+ nm [xml|<p class="h-blah"><em><img alt="Hello Only Nested Img!"></p>|] `shouldBe` pure "Hello Only Nested Img!"+ nm [xml|<p class="h-blah"><em><img alt="DOING"><img alt="WRONG">Goodbye Nested Img!</p>|] `shouldBe` pure "Goodbye Nested Img!"+ nm [xml|<p class="h-blah"><em><abbr title="Hello Only Nested Abbr!">HOA</abbr></p>|] `shouldBe` pure "Hello Only Nested Abbr!"+ nm [xml|<p class="h-blah"><em><abbr title="DOING"/><abbr title="WRONG"/>Goodbye Nested Abbr!</p>|] `shouldBe` pure "Goodbye Nested Abbr!"+ nm [xml|<p class="h-blah">Hello Text!</p>|] `shouldBe` pure "Hello Text!"++ it "parses implied u-photo" $ do+ let ph = implyProperty "photo" . documentRoot . parseLBS+ ph [xml|<img class="h-blah" src="selfie.png">|] `shouldBe` pure "selfie.png"+ ph [xml|<object class="h-blah" data="art.svg">|] `shouldBe` pure "art.svg"+ ph [xml|<div class="h-blah"><img src="selfie.png"/><em>yo</em>|] `shouldBe` pure "selfie.png"+ ph [xml|<div class="h-blah"><object data="art.svg"/><em>yo</em>|] `shouldBe` pure "art.svg"+ ph [xml|<div class="h-blah"><p class="onlychild"><img src="selfie.png"/><em>yo</em>|] `shouldBe` pure "selfie.png"+ ph [xml|<div class="h-blah"><p class="onlychild"><object data="art.svg"/><em>yo</em>|] `shouldBe` pure "art.svg"++ it "parses implied u-url" $ do+ let ur = implyProperty "url" . documentRoot . parseLBS+ ur [xml|<a class="h-blah" href="/hello/a">|] `shouldBe` pure "/hello/a"+ ur [xml|<area class="h-blah" href="/hello/area">|] `shouldBe` pure "/hello/area"+ ur [xml|<div class="h-blah"><em>what</em><a href="/hello/n/a">|] `shouldBe` pure "/hello/n/a"+ ur [xml|<div class="h-blah"><em>what</em><area href="/hello/n/area">|] `shouldBe` pure "/hello/n/area"+ ur [xml|<div class="h-blah"><div class="p-nope"><a href="/nope"></div>|] `shouldBe` Nothing+ ur [xml|<div class="h-blah"><a href="/nope" class="p-nope">n0pe</a>|] `shouldBe` Nothing
test-suite/Data/Microformats2/ParserSpec.hs view
@@ -1,257 +1,240 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax, CPP #-}+{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax #-} module Data.Microformats2.ParserSpec (spec) where -import Test.Hspec+import Test.Hspec hiding (shouldBe)+import Test.Hspec.Expectations.Pretty (shouldBe) import TestCommon-import Data.Default-import Data.Time.Clock-import Data.Time.Calendar-import Data.Microformats2+import Network.URI (parseURI) import Data.Microformats2.Parser-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif -{-# ANN module ("HLint: ignore Redundant do"::String) #-}- spec ∷ Spec spec = do-- describe "parseGeo" $ do- let parseGeo' = parseGeo . documentRoot . parseLBS-- it "parses valid h-geo" $ do- parseGeo' [xml|<div>- <p class="h-geo">- <span class="p-latitude">37.33168</span>- <span class="p-longitude">-122.03016</span>- <span class="p-altitude">1.2345</span>- </p>- <p class="h-geo">- <data class="p-latitude" value="123.45">- <input class="p-latitude" value="678.9">- </p>- </div>|] `shouldBe` [ def { geoLatitude = pure 37.33168, geoLongitude = pure (-122.03016), geoAltitude = pure 1.2345 }- , def { geoLatitude = [123.45, 678.9] } ]-- it "ignores invalid properties" $ do- parseGeo' [xml|<p class="h-geo">- <span class="p-latitude">HELLO WORLD!!</span>- <span class="p-altitude">1.2345</span>- </p>|] `shouldBe` [ def { geoAltitude = pure 1.2345 } ]-- describe "parseAdr" $ do- let parseAdr' = parseAdr . documentRoot . parseLBS-- it "parses valid h-adr" $ do- parseAdr' [xml|<div>- <article class="h-adr">- <span class="p-street-address">SA</span>- <p class="p-extended-address">EA</p>- <abbr class="p-post-office-box" title="PO">_</abbr>- <span class="p-locality">L</span>- <span class="p-region">R</span>- <span class="p-postal-code">PC</span>- <span class="p-country-name">C</span>- <span class="p-label">LB</span>- <span class="p-geo">G</span>- </article>- </div>|] `shouldBe` [ def { adrStreetAddress = pure "SA", adrExtendedAddress = pure "EA"- , adrPostOfficeBox = pure "PO", adrLocality = pure "L"- , adrRegion = pure "R", adrPostalCode = pure "PC"- , adrCountryName = pure "C", adrLabel = pure "LB"- , adrGeo = pure $ TextGeo "G" } ]-- it "parses p-geo" $ do- parseAdr' [xml|<div>- <span class="h-adr">- <span class="p-geo h-geo">- <span class="p-latitude">37.33168</span>- <span class="p-longitude">-122.03016</span>- <span class="p-altitude">1.2345</span>- </span>- </span>- </div>|] `shouldBe` [ def { adrGeo = [GeoGeo $ def { geoLatitude = pure 37.33168, geoLongitude = pure (-122.03016), geoAltitude = pure 1.2345 }] } ]-- it "ignores nested h-geo not marked as p-geo" $ do- parseAdr' [xml|<div>- <span class="h-adr">- <span class="h-geo"><span class="p-altitude">1.2345</span></span>- </span>- </div>|] `shouldBe` [ def ]-- it "parses geo properties into p-geo" $ do- parseAdr' [xml|<div>- <span class="h-adr">- <span class="p-latitude">37.33168</span>- <span class="p-longitude">-122.03016</span>- <span class="p-altitude">1.2345</span>- </span>- </div>|] `shouldBe` [ def { adrGeo = [GeoGeo $ def { geoLatitude = pure 37.33168, geoLongitude = pure (-122.03016), geoAltitude = pure 1.2345 }] } ]-- describe "parseCard" $ do- let parseCard' = parseCard . documentRoot . parseLBS-- it "parses valid h-card" $ do- parseCard' [xml|<div>- <p class="h-card">- <img class="u-photo" src="photo.png" alt="" />- <a class="p-name u-url" href="http://example.org">Joe Bloggs</a>- <a class="u-email" href="mailto:joebloggs@example.com">joebloggs@example.com</a>,- </p>- </div>|] `shouldBe` [ def { cardPhoto = pure "photo.png"- , cardUrl = pure "http://example.org"- , cardName = pure "Joe Bloggs"- , cardEmail = pure "mailto:joebloggs@example.com" } ]-- it "parses valid implied h-card" $ do- parseCard' [xml|<div>- <a class="h-card" href="http://example.org">Joe Bloggs</a>- <img class="h-card" src="http://example.org/photo.jpg" />- </div>|] `shouldBe` [ def { cardUrl = pure "http://example.org"- , cardName = pure "Joe Bloggs" }- , def { cardPhoto = pure "http://example.org/photo.jpg" }]-- it "parses p-adr" $ do- parseCard' [xml|<div>- <section class="h-card">- <p class="p-adr h-adr">- <span class="p-street-address">17</span>- <span class="p-locality">Reykjavik</span>- <span class="p-country-name">Iceland</span>- </p>- </section>- </div>|] `shouldBe` [ def { cardAdr = pure (AdrAdr $ def { adrStreetAddress = pure "17"- , adrLocality = pure "Reykjavik"- , adrCountryName = pure "Iceland" }) } ]-- it "ignores nested h-adr not marked as p-adr" $ do- parseCard' [xml|<div>- <section class="h-card">- <p class="h-adr"> <span class="p-country-name">Iceland</span> </p>- </section>- </div>|] `shouldBe` [ def ]-- it "parses adr and geo properties into p-adr" $ do- parseCard' [xml|<div>- <p class="h-card">- <span class="p-street-address">17</span>- <span class="p-locality">Reykjavik</span>- <span class="p-country-name">Iceland</span>- <span class="p-longitude">-122.03016</span>- </p>- </div>|] `shouldBe` [ def { cardAdr = pure (AdrAdr $ def { adrStreetAddress = pure "17"- , adrLocality = pure "Reykjavik"- , adrCountryName = pure "Iceland"- , adrGeo = [ GeoGeo $ def { geoLongitude = pure (-122.03016) } ] }) } ]-- it "parses h-geo into p-adr" $ do- parseCard' [xml|<div>- <section class="h-card">- <p class="p-geo h-geo"> <span class="p-longitude">-122.03016</span> </p>- </section>- </div>|] `shouldBe` [ def { cardAdr = pure (AdrAdr $ def { adrGeo = [ GeoGeo $ def { geoLongitude = pure (-122.03016) } ] }) } ]+ describe "parseItems" $ do+ let parseMf2'' c = parseMf2 c . documentRoot . parseLBS+ let parseMf2' = parseMf2'' def+ it "parses items" $ do+ parseMf2' [xml|<body>+ <div class="h-something aaa h-something-else">+ <h1 class="someclass p-name eeee">Name</h1>+ <header><A class="p-name u-url" href="http://main.url">other name</a></header>+ <span class="aaaaaap-nothingaaaa">---</span>+ <section class="p-org h-card">+ <a class="p-name">Card</a>+ </section>+ <template>+ <a href="http://ignore.this" class="p-org h-card">IGNORED</a>+ </template>+ <a href="http://card.url" class="p-org h-card">org</a>+ <time class="dt-published p-published dt-updated" datetime="2015-07-17T21:05:13+00:00">17<sup>th</sup> of July 2015 at 21:05</time>+ <Div class="h-nested-something">+ haz name+ </Div>+ <map name="primary">+ <area shape="circle" coords="200,250,25" class="h-area" />+ <area class="h-area" />+ </map>+ </div>+</body>|] `shouldBe` [json|{+ "items": [+ {+ "type": [ "h-something", "h-something-else" ],+ "properties": {+ "org": [+ {+ "type": [ "h-card" ],+ "properties": {+ "name": [ "Card" ]+ },+ "value": "Card"+ },+ {+ "type": [ "h-card" ],+ "properties": {+ "name": [ "org" ],+ "url": [ "http:\/\/card.url" ]+ },+ "value": "org"+ }+ ],+ "url": [ "http:\/\/main.url" ],+ "name": [ "Name", "other name" ],+ "published": [ "17th of July 2015 at 21:05", "2015-07-17T21:05:13+00:00" ],+ "updated": [ "2015-07-17T21:05:13+00:00" ]+ },+ "children": [+ {+ "type": [ "h-nested-something" ],+ "properties": {+ "name": [ "haz name" ]+ },+ "value": "haz name"+ },+ {+ "type": [ "h-area" ],+ "properties": {},+ "shape": "circle",+ "coords": "200,250,25",+ "value": null+ },+ {+ "type": [ "h-area" ],+ "properties": {},+ "value": null+ }+ ]+ }+ ],+ "rels": {},+ "rel-urls": {} - it "ignores nested h-geo not marked as p-geo" $ do- parseCard' [xml|<div>- <section class="h-card">- <p class="h-geo"> <span class="p-longitude">-122.03016</span> </p>- </section>- </div>|] `shouldBe` [ def ]+}|] - it "parses multiple things into p-adr" $ do- parseCard' [xml|<div>- <section class="h-card">- <p class="p-geo h-geo"> <span class="p-longitude">-122.03016</span> </p>- <span class="p-altitude">-122.03016</span>- <span class="p-country-name">Iceland</span>- <p class="p-adr h-adr"> <span class="p-locality">Reykjavik</span> </p>- </section>- </div>|] `shouldBe` [ def { cardAdr = [- (AdrAdr $ def { adrCountryName = pure "Iceland" - , adrGeo = [ GeoGeo $ def { geoAltitude = pure (-122.03016) }- , GeoGeo $ def { geoLongitude = pure (-122.03016) } ] })- , (AdrAdr $ def { adrLocality = pure "Reykjavik" }) ]} ]+ it "inserts value and html into e-* h-* properties" $ do+ parseMf2' [xml|<body class=h-parent><div class="h-child e-prop">some <abbr>html</abbr> and <span class="p-name">props|] `shouldBe` [json|{+ "items": [+ {+ "type": [ "h-parent" ],+ "properties": {+ "name": [ "some html and props" ],+ "prop": [+ {+ "type": [ "h-child" ],+ "properties": {+ "name": [ "props" ]+ },+ "value": "some html and props",+ "html": "some <abbr>html</abbr> and <span class=\"p-name\">props</span>"+ }+ ]+ }+ }+ ],+ "rels": {},+ "rel-urls": {}+}|] + it "parses nested properties but doesn't parse properties of nested microformats into the parent" $ do+ parseMf2' [xml|<body class=h-parent>+ <span class="p-outer"><span class="p-inner">some</span>thing</span>+ <div class="p-outer"><div class="h-child p-prop"><span class="p-aaa">a</span></div></div>+ <div class="h-child"><span class="p-bbb">b</span></div>|] `shouldBe` [json|{+ "items": [+ {+ "type": [ "h-parent" ],+ "properties": {+ "name": [ "something a b" ],+ "outer": [ "something", "a" ],+ "inner": [ "some" ],+ "prop": [ {+ "type": [ "h-child" ],+ "properties": {+ "name": [ "a" ],+ "aaa": [ "a" ]+ },+ "value": "a"+ } ]+ },+ "children": [ {+ "type": [ "h-child" ],+ "properties": {+ "name": [ "b" ],+ "bbb": [ "b" ]+ },+ "value": "b"+ } ]+ }+ ],+ "rels": {},+ "rel-urls": {}+}|] - it "parses p-org" $ do- parseCard' [xml|<div>- <section class="h-card">- <p class="p-org h-card"> <span class="p-name">IndieWebCamp</span> </p>- <span class="p-org">Microformats</span>- </section>- </div>|] `shouldBe` [ def { cardOrg = [ TextCard "Microformats"- , (CardCard $ def { cardName = pure "IndieWebCamp" }) ] }- , def { cardName = pure "IndieWebCamp" }]+ it "parses rels" $ do+ parseMf2' [xml|<html>+ <head><link rel="alternate feed me" href="/atom.xml" type="application/atom+xml"></head>+ <body>+ <a href="//example.com">test</a>+ <a href="https://twitter.com/myfreeweb" rel=me>twitter</a>+ <p><span><a href="https://github.com/myfreeweb" rel=me media=handheld hreflang=en>github</a></span></p>+ <footer><a href="/-1" rel="prev">-1</a></footer>+ </body>+</html>|] `shouldBe` [json|{+ "items": [],+ "rels": {+ "feed": [ "/atom.xml" ],+ "me": [ "https:\/\/github.com\/myfreeweb", "https:\/\/twitter.com\/myfreeweb", "/atom.xml" ],+ "alternate": [ "/atom.xml" ],+ "prev": [ "/-1" ]+ },+ "rel-urls": {+ "/atom.xml": { + "type": "application/atom+xml",+ "rels": [ "alternate", "feed", "me" ]+ },+ "https://twitter.com/myfreeweb": { + "text": "twitter",+ "rels": [ "me" ]+ },+ "https://github.com/myfreeweb": { + "text": "github",+ "rels": [ "me" ],+ "media": "handheld",+ "hreflang": "en"+ },+ "/-1": {+ "text": "-1",+ "rels": [ "prev" ]+ }+ }+}|] - describe "parseCite" $ do- let parseCite' = parseCite Strip . documentRoot . parseLBS+ it "resolves relative URIs" $ do - it "parses valid h-cite" $ do- parseCite' [xml|<div>- <article class="h-cite">- <a class="p-name u-url u-uid" href="https://youtu.be/E99FnoYqoII">Rails is Omakase</a>- <span class="p-author h-card"><span class="p-name">DHH</span></span>- <time class="dt-published">2013-01-25</time>- <p class="e-content">Rails is not that. Rails is omakase...</p>- </article>- </div>|] `shouldBe` [ def { citeName = pure "Rails is Omakase"- , citeUrl = pure "https://youtu.be/E99FnoYqoII"- , citeUid = pure "https://youtu.be/E99FnoYqoII"- , citeAuthor = pure $ CardCard $ def { cardName = pure "DHH" }- , citeContent = pure $ TextContent "Rails is not that. Rails is omakase..."- , citePublished = pure $ UTCTime (fromGregorian 2013 1 25) (secondsToDiffTime 0) } ]+ parseMf2' [xml|<html> <base href="http://example.com"> <a href="/atom.xml" rel=me>feed</a> </html>|] `shouldBe` [json|{+ "items": [],+ "rels": { "me": [ "http://example.com/atom.xml" ] },+ "rel-urls": { "http://example.com/atom.xml": { "text": "feed", "rels": [ "me" ] } } }|] + parseMf2'' (def { baseUri = parseURI "http://com.example" }) [xml|<html> <a href="/atom.xml" rel=me>feed</a> </html>|] `shouldBe` [json|{+ "items": [],+ "rels": { "me": [ "http://com.example/atom.xml" ] },+ "rel-urls": { "http://com.example/atom.xml": { "text": "feed", "rels": [ "me" ] } } }|] - describe "parseEntry" $ do- let parseEntry' m = parseEntry m . documentRoot . parseLBS+ parseMf2'' (def { baseUri = parseURI "http://com.example" }) [xml|<html> <base href="http://example.com"> <a href="/atom.xml" rel=me>feed</a> </html>|] `shouldBe` [json|{+ "items": [],+ "rels": { "me": [ "http://example.com/atom.xml" ] },+ "rel-urls": { "http://example.com/atom.xml": { "text": "feed", "rels": [ "me" ] } } }|] - it "parses valid h-entry" $ do- parseEntry' Strip [xml|<div>- <article class="h-entry">- <a class="p-name u-url u-uid" href="https://youtu.be/E99FnoYqoII">Rails is Omakase</a>- <span class="p-author h-card"><span class="p-name">DHH</span></span>- <a href="http://david.heinemeierhansson.com" class="p-author h-card">DHH</a>- <a href="http://david.heinemeierhansson.com" class="p-author">David</a>- <time class="dt-published">2013-01-25</time>- <time class="dt-updated">2013-01-25T01:23</time>- <p class="e-content">Rails is not that. Rails is omakase...</p>- </article>- </div>|] `shouldBe` [ def { entryName = pure "Rails is Omakase"- , entryUrl = pure "https://youtu.be/E99FnoYqoII"- , entryUid = pure "https://youtu.be/E99FnoYqoII"- , entryAuthor = [ TextCard "David"- , CardCard $ def { cardName = pure "DHH" }- , CardCard $ def { cardName = pure "DHH", cardUrl = pure "http://david.heinemeierhansson.com" } ]- , entryContent = pure $ TextContent "Rails is not that. Rails is omakase..."- , entryPublished = pure $ UTCTime (fromGregorian 2013 1 25) (secondsToDiffTime 0)- , entryUpdated = pure $ UTCTime (fromGregorian 2013 1 25) (secondsToDiffTime 4980) } ]+ parseMf2'' (def { baseUri = parseURI "http://com.example" }) [xml|<html> <base href="/base/"> <a href="atom.xml" rel=me>feed</a> </html>|] `shouldBe` [json|{+ "items": [],+ "rels": { "me": [ "http://com.example/base/atom.xml" ] },+ "rel-urls": { "http://com.example/base/atom.xml": { "text": "feed", "rels": [ "me" ] } } }|] - it "supports different html content modes" $ do- let src = [xml|<div>- <article class="h-entry">- <p class="e-content"><script>alert('XSS')</script><a href="http://rubyonrails.org" onclick="alert()">Rails</a> is not that. Rails is omakase...</p>- </article>- </div>|]- parseEntry' Unsafe src `shouldBe` [ def { entryContent = pure $ TextContent "<script>alert('XSS')</script><a href=\"http://rubyonrails.org\" onclick=\"alert()\">Rails</a> is not that. Rails is omakase..." } ]- parseEntry' Strip src `shouldBe` [ def { entryContent = pure $ TextContent "alert('XSS')Rails is not that. Rails is omakase..." } ]- parseEntry' Escape src `shouldBe` [ def { entryContent = pure $ TextContent "<script>alert('XSS')</script><a href=\"http://rubyonrails.org\" onclick=\"alert()\">Rails</a> is not that. Rails is omakase..." } ]- parseEntry' Sanitize src `shouldBe` [ def { entryContent = pure $ TextContent "<a href=\"http://rubyonrails.org\">Rails</a> is not that. Rails is omakase..." } ]+ parseMf2' [xml|<html> <base href="/base/"> <a href="atom.xml" rel=me>feed</a> </html>|] `shouldBe` [json|{+ "items": [],+ "rels": { "me": [ "/base/atom.xml" ] },+ "rel-urls": { "/base/atom.xml": { "text": "feed", "rels": [ "me" ] } } }|] - it "parses p-location" $ do- parseEntry' Strip [xml|<div>- <article class="h-entry">- <p class="p-location h-card">- <a class="p-name u-url" href="http://penisland.net">Pen Island</a>- </p>- <p class="p-location h-adr">- <span class="p-country-name">USA</span>- </p>- <p class="p-location h-geo">- <data class="p-latitude" value="123.45">- </p>- </article>- </div>|] `shouldBe` [ def { entryLocation = [ CardLoc $ def { cardName = pure "Pen Island", cardUrl = pure "http://penisland.net" }- , AdrLoc $ def { adrCountryName = pure "USA" }- , GeoLoc $ def { geoLatitude = pure 123.45 } ] } ]+ parseMf2'' (def { baseUri = parseURI "http://com.example" }) [xml|<html>+ <base href="/base/">+ <a href="atom.xml" rel=me>feed</a>+ <div class=h-card>+ <h1 class=p-name>card</h1>+ <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>+</html>|] `shouldBe` [json|{+ "items": [+ {+ "type": [ "h-card" ],+ "properties": {+ "photo": [ "http://com.example/base/photo.webp" ],+ "url": [ "http://com.example/base/url", "/not/resolved" ],+ "name": [ "card" ]+ }+ }+ ],+ "rels": { "me": [ "http://com.example/base/atom.xml" ] },+ "rel-urls": { "http://com.example/base/atom.xml": { "text": "feed", "rels": [ "me" ] } }+}|]