microformats2-parser 1.0.1.2 → 1.0.1.3

raw patch · 10 files changed

+206/−16 lines, 10 filesdep +attoparsecdep +errorsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: attoparsec, errors

API changes (from Hackage documentation)

Files

• README.md +1/−0
• executable/Main.hs +1/−1
• library/Data/Microformats2/Parser.hs +1/−1
• library/Data/Microformats2/Parser/Date.hs +159/−0
• library/Data/Microformats2/Parser/HtmlUtil.hs +3/−2
• library/Data/Microformats2/Parser/Property.hs +17/−9
• library/Data/Microformats2/Parser/Util.hs +1/−1
• microformats2-parser.cabal +4/−1
• test-suite/Data/Microformats2/Parser/PropertySpec.hs +17/−1
• test-suite/Data/Microformats2/ParserSpec.hs +2/−0

@@ -6,6 +6,7 @@  - parses `items`, `rels`, `rel-urls` - resolves relative URLs (with support for the `<base>` tag)+- parses the [value-class-pattern](http://microformats.org/wiki/value-class-pattern), including date and time normalization - handles malformed HTML (the actual HTML parser is [tagstream-conduit]) - high performance - extensively tested

@@ -3,7 +3,7 @@  module Main (main) where -#if __GLASGOW_HASKELL__ < 709+#if !MIN_VERSION_base(4,8,0) import           Control.Applicative #endif import           Control.Exception

@@ -13,7 +13,7 @@  import           Text.HTML.DOM import           Text.XML.Lens hiding ((.=))-#if __GLASGOW_HASKELL__ < 709+#if !MIN_VERSION_base(4,8,0) import           Control.Applicative #endif import           Data.Microformats2.Parser.Property

@@ -0,0 +1,159 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings, UnicodeSyntax, CPP, TypeFamilies #-}++module Data.Microformats2.Parser.Date where++#if !MIN_VERSION_base(4,8,0)+import           Prelude hiding (sequence)+import           Data.Traversable+#endif+import           Control.Applicative+import           Control.Monad+import           Control.Error.Util (hush)+import           Text.Printf+import           Data.Maybe+import           Data.Foldable+import           Data.Attoparsec.Text+import qualified Data.Time.Calendar as C+import qualified Data.Time.Calendar.OrdinalDate as O+import qualified Data.Text as T++data Date = Date Int Int Int+instance Show Date where+  show (Date y m d) = printf "%d-%02d-%02d" y m d++data HourType = TwentyFourHour | AMHour | PMHour+data Time = Time Int Int Int+instance Show Time where+  show (Time h m s) = printf "%02d:%02d:%02d" h m s++data DateTime = DateTime Date Time+instance Show DateTime where+  show (DateTime d t) = show d ++ "T" ++ show t++data ZoneType = Plus | Minus+data Zone = Zone ZoneType Int Int+instance Show Zone where+  show (Zone Plus  h m) = printf "+%02d:%02d" h m+  show (Zone Minus h m) = printf "-%02d:%02d" h m++data TimeZone = TimeZone Time Zone+instance Show TimeZone where+  show (TimeZone t z) = show t ++ show z++data DateTimeZone = DateTimeZone DateTime Zone+instance Show DateTimeZone where+  show (DateTimeZone dt z) = show dt ++ show z++data DTPart = DatePart Date | TimePart Time | ZonePart Zone | TimeZonePart TimeZone | DateTimePart DateTime | DateTimeZonePart DateTimeZone+instance Show DTPart where+  show (DatePart d) = show d+  show (TimePart t) = show t+  show (ZonePart z) = show z+  show (TimeZonePart tz) = show tz+  show (DateTimePart dt) = show dt+  show (DateTimeZonePart dtz) = show dtz++isDatePart, isTimePart, isZonePart, isTimeZonePart, isDateTimePart, isDateTimeZonePart ∷ DTPart → Bool+isDatePart (DatePart _) = True+isDatePart _ = False+isTimePart (TimePart _) = True+isTimePart _ = False+isZonePart (ZonePart _) = True+isZonePart _ = False+isTimeZonePart (TimeZonePart _) = True+isTimeZonePart _ = False+isDateTimePart (DateTimePart _) = True+isDateTimePart _ = False+isDateTimeZonePart (DateTimeZonePart _) = True+isDateTimeZonePart _ = False++parseDate ∷ Parser Date+parseDate = parseDate'+  where parseDate' = do+          year ← read <$> count 4 digit+          char '-'+          parseMMDD year <|> parseDDD year+        parseMMDD year = do+          mm ← read <$> count 2 digit+          char '-'+          dd ← read <$> count 2 digit+          return $ Date year mm dd+        parseDDD year = do+          ddd ← read <$> count 3 digit+          let (_, mm, dd) = C.toGregorian $ O.fromOrdinalDate (fromIntegral year) ddd+          return $ Date year mm dd++parseHourType ∷ Parser HourType+parseHourType =+      ((char 'a' <|> char 'A') >> option '.' (char '.') >> (char 'm' <|> char 'M') >> option '.' (char '.') >> return AMHour)+  <|> ((char 'p' <|> char 'P') >> option '.' (char '.') >> (char 'm' <|> char 'M') >> option '.' (char '.') >> return PMHour)++parseTime ∷ Parser Time+parseTime = do+  hrs  ← read <$> count 2 digit+  mins ← option 0 $ char ':' >> read <$> count 2 digit+  secs ← option 0 $ char ':' >> read <$> count 2 digit+  htyp ← option TwentyFourHour $ parseHourType+  let hrs' = case (hrs, htyp) of+               (12, AMHour) → 00+               (x,  PMHour) | x < 12 → x + 12+               (x,  _) → x+  return $ Time hrs' mins secs++parseZone ∷ Parser Zone+parseZone = (char 'Z' >> return (Zone Plus 0 0)) <|> parseZone'+  where parseZone' = do+          htyp ← (char '+' >> return Plus) <|> (char '-' >> return Minus)+          hrs  ← read <$> count 2 digit+          mins ← option 0 $ option ':' (char ':') >> read <$> count 2 digit+          return $ Zone htyp hrs mins++parseTimeZone ∷ Parser TimeZone+parseTimeZone = do+  t ← parseTime+  z ← parseZone+  return $ TimeZone t z++parseDateTime ∷ Parser DateTime+parseDateTime = do+  d ← parseDate+  option 'T' $ char 'T' <|> char ' '+  t ← parseTime+  return $ DateTime d t++parseDateTimeZone ∷ Parser DateTimeZone+parseDateTimeZone = do+  dt ← parseDateTime+  z ← parseZone+  return $ DateTimeZone dt z++parseDTPart ∷ Parser DTPart+parseDTPart =+      (liftM DateTimeZonePart parseDateTimeZone)+  <|> (liftM DateTimePart parseDateTime)+  <|> (liftM DatePart parseDate)+  <|> (liftM TimeZonePart parseTimeZone)+  <|> (liftM TimePart parseTime)+  <|> (liftM ZonePart parseZone)++parseDTParts ∷ (Traversable φ, Monoid (φ DTPart)) ⇒ φ T.Text → φ DTPart+parseDTParts = fromMaybe mempty . sequence . fmap (hush . parseOnly parseDTPart)++normalizeDTParts ∷ (Foldable φ) ⇒ φ DTPart → Maybe DTPart+normalizeDTParts ps = asum [ find isDateTimeZonePart ps, findDateTime, findDateAndTime, find isDatePart ps, find isTimeZonePart ps, find isTimePart ps ]+  where findDateTime = do+          (DateTimePart dt) ← find isDateTimePart ps+          return $ case find isZonePart ps of+            Just (ZonePart z) → DateTimeZonePart $ DateTimeZone dt z+            _ → DateTimePart dt+        findDateAndTime = do+          (DatePart d) ← find isDatePart ps+          case find isTimeZonePart ps of+            Just (TimeZonePart (TimeZone t z)) → return $ DateTimeZonePart $ DateTimeZone (DateTime d t) z+            _ → findTime d+        findTime d = do+          (TimePart t) ← find isTimePart ps+          return $ case find isZonePart ps of+            Just (ZonePart z) → DateTimeZonePart $ DateTimeZone (DateTime d t) z+            _ → DateTimePart $ DateTime d t

@@ -11,7 +11,7 @@ , deduplicateElements ) where -#if __GLASGOW_HASKELL__ < 709+#if !MIN_VERSION_base(4,8,0) import           Control.Applicative #endif import qualified Data.Map as M@@ -56,7 +56,8 @@ _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+  NodeElement e → if' (safeTagName $ nameLocalName (elementName e)) $+                    Just . collapseWhitespace . TL.toStrict . renderMarkup . contents . toMarkup $ e   _ → Nothing  _InnerTextWithImgs ∷ Prism' Node Text

@@ -3,7 +3,7 @@  module Data.Microformats2.Parser.Property where -#if __GLASGOW_HASKELL__ < 709+#if !MIN_VERSION_base(4,8,0) import           Control.Applicative #endif import qualified Data.Text as T@@ -13,10 +13,11 @@ import qualified Data.Map as M import           Data.Maybe import           Text.XML.Lens hiding (re)+import           Data.Microformats2.Parser.Date (normalizeDTParts, parseDTParts) import           Data.Microformats2.Parser.HtmlUtil import           Data.Microformats2.Parser.Util -unwrapName ∷ (Name, a) → (Text, a)+unwrapName ∷ (Name, α) → (Text, α) unwrapName (Name n _ _, val) = (n, val)  classes ∷ Element → [Text]@@ -72,16 +73,23 @@ 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 ∷ [Element → Maybe Text] → Element → Maybe [Text] extractValueClassPattern fs e = if' (isJust $ e ^? valueParts) extractValueParts-  where extractValueParts   = Just . T.concat . catMaybes $ e ^.. valueParts . to extractValuePart+  where extractValueParts   = Just . catMaybes $ e ^.. valueParts . to extractValuePart         extractValuePart e' = asum $ fs <*> pure e'-        valueParts          ∷ Applicative f => (Element → f Element) → Element → f Element+        valueParts          ∷ Applicative φ => (Element → φ Element) → Element → φ Element         valueParts          = entire . hasOneClass ["value", "value-title"] +extractValueClassPatternConcat ∷ [Element → Maybe Text] → Element → Maybe Text+extractValueClassPatternConcat fs e = T.concat <$> extractValueClassPattern fs e++extractValueClassPatternDate ∷ [Element → Maybe Text] → Element → Maybe Text+extractValueClassPatternDate fs e = asum [ T.pack . show <$> (normalizeDTParts $ parseDTParts $ fromMaybe [] valueParts), T.concat <$> valueParts ]+  where valueParts = extractValueClassPattern fs e+ extractP ∷ Element → Maybe Text extractP e =-  asum $ [ extractValueClassPattern [extractValueTitle, extractValue]+  asum $ [ extractValueClassPatternConcat [extractValueTitle, extractValue]          , getAbbrTitle, getDataInputValue, getImgAreaAlt, getInnerTextWithImgs ] <*> pure e  extractU ∷ Element@@ -90,15 +98,15 @@   asum $ [ (, True) <$> getAAreaHref e          , (, True) <$> getImgAudioVideoSourceSrc e          , (, True) <$> getObjectData e-         , (, False) <$> extractValueClassPattern [extractValueTitle, extractValue] e+         , (, False) <$> extractValueClassPatternConcat [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 ]+  asum $ (extractValueClassPatternDate ms : ms ++ [getInnerTextRaw]) <*> pure e+  where ms = [ getTimeInsDelDatetime, extractValueTitle, extractValue ]  implyProperty ∷ String → Element → Maybe Text implyProperty "name"  e = asum $ [ getImgAreaAlt, getAbbrTitle

@@ -3,7 +3,7 @@  module Data.Microformats2.Parser.Util where -#if __GLASGOW_HASKELL__ < 709+#if !MIN_VERSION_base(4,8,0) import           Control.Applicative #endif import           Data.Aeson

@@ -1,5 +1,5 @@ name:            microformats2-parser-version:         1.0.1.2+version:         1.0.1.3 synopsis:        A Microformats 2 parser. category:        Web homepage:        https://github.com/myfreeweb/microformats2-parser@@ -28,6 +28,7 @@       , time       , either       , safe+      , errors       , containers       , unordered-containers       , vector@@ -41,10 +42,12 @@       , blaze-markup       , xss-sanitize       , pcre-heavy+      , attoparsec     default-language: Haskell2010     exposed-modules:         Data.Microformats2.Parser         Data.Microformats2.Parser.Property+        Data.Microformats2.Parser.Date         Data.Microformats2.Parser.HtmlUtil         Data.Microformats2.Parser.Util     ghc-options: -Wall

@@ -5,7 +5,7 @@ import           Test.Hspec import           TestCommon import           Data.Microformats2.Parser.Property-#if __GLASGOW_HASKELL__ < 709+#if !MIN_VERSION_base(4,8,0) import           Control.Applicative #endif @@ -58,6 +58,22 @@             <time class="value" datetime="ti">TIME</time>             <ins class="value" datetime="me">lol</time>           </span>|] `shouldBe` pure "vcptime"+      dt [xml|<span class="dt-updated">+            <time class="value" datetime="05:55-0700">VCP</time>+            <time class="value">2015-08-28</time>+          </span>|] `shouldBe` pure "2015-08-28T05:55:00-07:00"+      dt [xml|<span class="dt-updated">+            <span class="value-title" title="Z"></span>+            <time class="value" datetime="05:55"></time>+            <time class="value">2015-08-28</time>+          </span>|] `shouldBe` pure "2015-08-28T05:55:00+00:00"+      dt [xml|<span class="dt-updated">+            <span class="value-title" title="+01:00"></span>+            <time class="value">2015-08-28</time>+          </span>|] `shouldBe` pure "2015-08-28"+      dt [xml|<span class="dt-updated">+            <time class="value" datetime="2015-08-28 05:55:00+00"></time>+          </span>|] `shouldBe` pure "2015-08-28T05:55:00+00:00"       dt [xml|<span class="dt-updated">date</span>|] `shouldBe` pure "date"    describe "implyProperty" $ do

@@ -19,6 +19,7 @@     <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>+    <div class="e-content">Some <abbr>XSS</abbr><script>alert('pwned')</script></div>     <section class="p-org h-card">       <a class="p-name">Card</a>     </section>@@ -59,6 +60,7 @@                 ],                 "url": [ "http:\/\/main.url" ],                 "name": [ "Name", "other name" ],+                "content": [ { "html": "Some <abbr>XSS</abbr>", "value": "Some XSS" } ],                 "published": [ "17th of July 2015 at 21:05", "2015-07-17T21:05:13+00:00" ],                 "updated": [ "2015-07-17T21:05:13+00:00" ]             },