microformats2-parser (empty) → 0.1.0
raw patch · 8 files changed
+875/−0 lines, 8 filesdep +basedep +blaze-markupdep +containers
Dependencies added: base, blaze-markup, containers, data-default, either, hspec, html-conduit, microformats2-parser, microformats2-types, pcre-heavy, raw-strings-qq, safe, template-haskell, text, time, xml-lens, xss-sanitize
Files
- README.md +40/−0
- UNLICENSE +24/−0
- library/Data/Microformats2/Parser.hs +172/−0
- library/Data/Microformats2/Parser/Internal.hs +222/−0
- microformats2-parser.cabal +63/−0
- test-suite/Data/Microformats2/Parser/InternalSpec.hs +96/−0
- test-suite/Data/Microformats2/ParserSpec.hs +257/−0
- test-suite/Spec.hs +1/−0
+ README.md view
@@ -0,0 +1,40 @@+# 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)++[Microformats 2] parser for Haskell!++Originally created for [sweetroll] :-)++The types are located in a separate package called [microformats2-types].++[Microformats 2]: http://microformats.org/wiki/microformats2+[sweetroll]: https://github.com/myfreeweb/sweetroll+[microformats2-types]: https://github.com/myfreeweb/microformats2-types++## Development++Use [stack] to build. +Use ghci to run tests quickly with `:test` (see the `.ghci` file).++```bash+$ stack build++$ stack test && rm tests.tix++$ stack ghci --ghc-options="-fno-hpc"+```++[stack]: https://github.com/commercialhaskell/stack++## Contributing++Please feel free to submit pull requests!+Bugfixes and simple non-breaking improvements will be accepted without any questions :-)++By participating in this project you agree to follow the [Contributor Code of Conduct](http://contributor-covenant.org/version/1/2/0/).++[The list of contributors is available on GitHub](https://github.com/myfreeweb/microformats2-parser/graphs/contributors).++## License++This is free and unencumbered software released into the public domain. +For more information, please refer to the `UNLICENSE` file or [unlicense.org](http://unlicense.org).
+ UNLICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <http://unlicense.org/>
+ library/Data/Microformats2/Parser.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE UnicodeSyntax, OverloadedStrings, CPP #-}++module Data.Microformats2.Parser (+ module Data.Microformats2.Parser++ -- * HTML parsing stuff (from html-conduit, xml-lens)+, documentRoot+, parseLBS+, sinkDoc+) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif+import Control.Monad+import Data.Microformats2+import Data.Microformats2.Parser.Internal+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"++-- | 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") }+++-- | Parses all h-card entries inside of an element.+parseCard ∷ Element → [Card]+parseCard = map extractCard . findCard++-- | Finds all h-card elements inside of an element.+findCard ∷ Element → [Element]+findCard = findMicroformat "h-card"++-- | 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 }+++-- | Parses all h-cite entries inside of an element.+parseCite ∷ HtmlContentMode → Element → [Cite]+parseCite m = map (extractCite m) . findCite++-- | Finds all h-cite elements inside of an element.+findCite ∷ Element → [Element]+findCite = findMicroformat "h-cite"++-- | 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 }+++-- | Parses all h-entry entries inside of an element.+parseEntry ∷ HtmlContentMode → Element → [Entry]+parseEntry m = map (extractEntry m) . findEntry++-- | Finds all h-entry elements inside of an element.+findEntry ∷ Element → [Element]+findEntry = findMicroformat "h-entry"++-- | 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 }++processContent ∷ HtmlContentMode → Element → [LT.Text]+processContent Unsafe = extractPropertyContent getAllHtml P "content"+processContent Strip = extractPropertyContent getAllText P "content"+processContent Escape = map (LT.replace "<" "<" . LT.replace ">" ">" . LT.replace "&" "&") . extractPropertyContent getAllHtml P "content"+processContent Sanitize = extractPropertyContent getAllHtmlSanitized P "content"
+ library/Data/Microformats2/Parser/Internal.hs view
@@ -0,0 +1,222 @@+{-# 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++notMicroformat ∷ Traversal' Element Element+notMicroformat = attributeSatisfies "class" $ not . (≈ [re|h-\w+|])++entireNotMicroformat ∷ Traversal' Element Element+entireNotMicroformat f e@(Element _ _ ns) = com <$> f e <*> traverse (_Element (notMicroformat $ entireNotMicroformat f)) ns+ where com (Element n a _) = Element n a++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
+ microformats2-parser.cabal view
@@ -0,0 +1,63 @@+name: microformats2-parser+version: 0.1.0+synopsis: A Microformats 2 parser.+category: Web+homepage: https://github.com/myfreeweb/microformats2-parser+author: Greg V+copyright: 2015 Greg V <greg@unrelenting.technology>+maintainer: greg@unrelenting.technology+license: PublicDomain+license-file: UNLICENSE+build-type: Simple+cabal-version: >= 1.18+extra-source-files:+ README.md+tested-with:+ GHC == 7.10.2++source-repository head+ type: git+ location: git://github.com/myfreeweb/microformats2-parser.git++library+ build-depends:+ base >= 4.0.0.0 && < 5+ , text+ , time+ , either+ , safe+ , containers+ , data-default+ , microformats2-types+ , html-conduit+ , xml-lens+ , blaze-markup+ , xss-sanitize+ , pcre-heavy+ default-language: Haskell2010+ exposed-modules:+ Data.Microformats2.Parser+ Data.Microformats2.Parser.Internal+ ghc-options: -Wall+ hs-source-dirs: library++test-suite tests+ build-depends:+ base >= 4.0.0.0 && < 5+ , time+ , hspec+ , template-haskell+ , microformats2-parser+ , microformats2-types+ , raw-strings-qq+ , data-default+ , html-conduit+ , xml-lens+ default-language: Haskell2010+ ghc-options: -threaded -Wall -fhpc+ hs-source-dirs: test-suite+ main-is: Spec.hs+ other-modules:+ Data.Microformats2.ParserSpec+ Data.Microformats2.Parser.InternalSpec+ type: exitcode-stdio-1.0
+ test-suite/Data/Microformats2/Parser/InternalSpec.hs view
@@ -0,0 +1,96 @@+{-# 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><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/ParserSpec.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax, CPP #-}++module Data.Microformats2.ParserSpec (spec) where++import Test.Hspec+import TestCommon+import Data.Default+import Data.Time.Clock+import Data.Time.Calendar+import Data.Microformats2+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) } ] }) } ]++ 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 "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" }]++ describe "parseCite" $ do+ let parseCite' = parseCite Strip . documentRoot . parseLBS++ 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="p-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) } ]+++ describe "parseEntry" $ do+ let parseEntry' m = parseEntry m . documentRoot . parseLBS++ 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="p-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) } ]++ it "supports different html content modes" $ do+ let src = [xml|<div>+ <article class="h-entry">+ <p class="p-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..." } ]++ 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 } ] } ]
+ test-suite/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}