packages feed

microformats2-parser 1.0.2.0 → 1.0.2.1

raw patch · 7 files changed

+70/−54 lines, 7 files

Files

README.md view
@@ -1,12 +1,10 @@ [![Hackage](https://img.shields.io/hackage/v/microformats2-parser.svg?style=flat)](https://hackage.haskell.org/package/microformats2-parser)-[![unlicense](https://img.shields.io/badge/un-license-green.svg?style=flat)](http://unlicense.org)+[![unlicense](https://img.shields.io/badge/un-license-green.svg?style=flat)](https://unlicense.org)  # microformats2-parser  [Microformats 2] parser for Haskell! [#IndieWeb] -Originally created for [sweetroll].- - parses `items`, `rels`, `rel-urls` - resolves relative URLs (with support for the `<base>` tag), including inside of `html` for `e-*` properties - parses the [value-class-pattern](http://microformats.org/wiki/value-class-pattern), including date and time normalization@@ -19,10 +17,9 @@  [Microformats 2]: http://microformats.org/wiki/microformats2 [#IndieWeb]: https://indieweb.org-[sweetroll]: https://github.com/unrelentingtech/sweetroll [tagstream-conduit]: https://hackage.haskell.org/package/tagstream-conduit [JF2]: https://www.w3.org/TR/jf2/-[http-link-header]: https://github.com/unrelentingtech/http-link-header+[http-link-header]: https://codeberg.org/valpackett/http-link-header  ## [DEMO PAGE](https://unrelenting.technology/mf2/) @@ -65,14 +62,6 @@ ```  [stack]: https://github.com/commercialhaskell/stack--## Contributing--Please feel free to submit pull requests!--By participating in this project you agree to follow the [Contributor Code of Conduct](https://www.contributor-covenant.org/version/1/4/code-of-conduct/) and to release your contributions under the Unlicense.--[The list of contributors is available on GitHub](https://github.com/unrelentingtech/microformats2-parser/graphs/contributors).  ## License
executable/WebApp.hs view
@@ -27,12 +27,12 @@   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, input:not([type=checkbox]), textarea, button { width: 100%; } input:not([type=checkbox]), textarea, label { margin-bottom: 1em; display: block; } textarea { resize: vertical; min-height: 15em; } 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:not([type=checkbox]), textarea, button { width: 100%; border-radius: 3px; } input:not([type=checkbox]), textarea, label { margin-bottom: 1em; display: block; } textarea { resize: vertical; min-height: 15em; } pre { white-space: pre-wrap; } footer { margin: 2em 0; } @media screen and (prefers-color-scheme: dark) { html { background: #222; color: #f1f1f1; } input, textarea { background: #444; color: #fefefe; } a { color: #da4343; } a:hover { color: #ea6363; } }"   H.body $ do     H.header $ do       h1 $ do-        a ! href "https://github.com/unrelentingtech/microformats2-parser" $ "microformats2-parser"-      a ! href "https://github.com/unrelentingtech/microformats2-parser" $ img ! alt "GitHub" ! src "https://img.shields.io/badge/git-hub-gray.svg?style=flat"+        a ! href "https://codeberg.org/valpackett/microformats2-parser" $ "microformats2-parser"+      a ! href "https://codeberg.org/valpackett/microformats2-parser" $ img ! alt "Codeberg" ! src "https://img.shields.io/badge/code-berg-blue.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"       " "@@ -57,11 +57,12 @@       let gi = $$tGitInfoCwd       p $ do         "Version: "-        a ! href (toValue $ "https://github.com/unrelentingtech/microformats2-parser/commit/" <> giHash gi) $ toMarkup $ take 12 $ giHash gi+        a ! href (toValue $ "https://codeberg.org/valpackett/microformats2-parser/commit/" <> giHash gi) $ toMarkup $ take 12 $ giHash gi         " ("         toMarkup $ giCommitDate gi         ")"-      a ! href "https://unrelenting.technology" ! rel "author" $ "unrelenting.technology"+      "made by "+      a ! href "https://val.packett.cool" ! rel "author" $ "Val Packett"  app ∷ IO Application app = scottyApp $ do
library/Data/Microformats2/Jf2.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, OverloadedStrings, CPP #-}  module Data.Microformats2.Jf2 (mf2ToJf2) where @@ -6,7 +6,12 @@ import           Control.Lens import           Data.Maybe import           Data.Aeson.Lens-import qualified Data.HashMap.Strict as HMS+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Key as K+#else+import qualified Data.HashMap.Strict as KM+#endif import qualified Data.Vector as V import qualified Data.Text as T import           Data.Microformats2.Parser.UnsafeUtil@@ -15,15 +20,18 @@ mf2ToJf2 val@(Object _) = flattenItems $ processItems $ processChildren $ flattenProps $ val & key "type" %~ flattenType   where flattenType t@(Array _) = fromMaybe Null $ fmap (& _String %~ (\x → fromMaybe x $ T.stripPrefix "h-" x)) $ t ^? nth 0         flattenType x = x-        flattenProps p@(Object o) = Object $ HMS.delete "value" $ HMS.delete "properties" $-          foldl (\acc (k, v) → HMS.insert k (flattenArr $ processProp k v) acc) o $+        flattenProps p@(Object o) = Object $ KM.delete "value" $ KM.delete "properties" $+          foldl (\acc (k, v) → KM.insert k (flattenArr $ processProp k v) acc) o $+#if MIN_VERSION_aeson(2,0,0)+          map (\(k, v) -> (K.fromText k, v)) $+#endif           p ^@.. key "properties" . members         flattenProps x = x         processProp "content" v = v & _Array . each %~ processContent         processProp _ v = v & _Array . each %~ mf2ToJf2         processContent (Object o) =-          case HMS.lookup "value" o of-               Just v → Object $ HMS.delete "value" $ HMS.insert "text" v o+          case KM.lookup "value" o of+               Just v → Object $ KM.delete "value" $ KM.insert "text" v o                _ → Object o         processContent x = x         flattenArr (Array v) | V.length v == 1 = V.head v
library/Data/Microformats2/Parser.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Safe, NoImplicitPrelude, UnicodeSyntax, OverloadedStrings #-}+{-# LANGUAGE Trustworthy, NoImplicitPrelude, UnicodeSyntax, OverloadedStrings, CPP #-}  module Data.Microformats2.Parser (   Mf2ParserSettings (..)@@ -18,12 +18,25 @@ import           Data.Microformats2.Parser.Util import           Data.Aeson.Lens import           Data.Char (isSpace)-import qualified Data.HashMap.Strict as HMS+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Key as K+#else+import qualified Data.HashMap.Strict as KM+#endif import           Data.Maybe import qualified Data.Text as T import           Network.URI import           Safe (headMay) +#if MIN_VERSION_aeson(2,0,0)+toK :: T.Text -> K.Key+toK = K.fromText+#else+toK :: a -> a+toK = id+#endif+ data Mf2ParserSettings = Mf2ParserSettings   { htmlMode ∷ HtmlContentMode   , baseUri  ∷ Maybe URI }@@ -54,18 +67,18 @@ -- lens-aeson's 'key' doesn't add new keys :-(  addValue ∷ T.Text → Value → Value → Value-addValue "p" v@(Object o) f = let v' = (fromMaybe f $ v ^? key "properties" . key "name" . nth 0) in Object $ if v' == Null then o else HMS.insert "value" v' 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 "p" v@(Object o) f = let v' = (fromMaybe f $ v ^? key "properties" . key "name" . nth 0) in Object $ if v' == Null then o else KM.insert "value" v' o+addValue "e" (Object o)   f = Object $ KM.insert "value" (fromMaybe Null $ f ^? key "value") $ KM.insert "html" (fromMaybe Null $ f ^? key "html") o+addValue "u" v@(Object o) f = Object $ KM.insert "value" (fromMaybe f $ v ^? key "properties" . key "url" . nth 0) o+addValue _   (Object o)   f = Object $ KM.insert "value" f o addValue _   x            _ = x  addImpliedProperties ∷ Mf2ParserSettings → Element → Value → Value addImpliedProperties settings e v@(Object o) = Object $ addIfNull "photo" "photo" resolveURI' $ addIfNull "url" "url" resolveURI' $ addIfNullAndNoOthers "name" "name" id o-  where addIfNull nameJ nameH f obj = if isNothing $ v ^? key nameJ then HMS.insert nameJ (vsingleton $ f <$> implyProperty nameH e) obj else obj+  where addIfNull nameJ nameH f obj = if isNothing $ v ^? key nameJ then KM.insert (toK nameJ) (vsingleton $ f <$> implyProperty nameH e) obj else obj         addIfNullAndNoOthers nameJ nameH f obj =           if isNothing (v ^? key nameJ) && isNothing (v ^? key "children") && isNothing (e ^? plate . cosmos . peElements)-             then HMS.insert nameJ (vsingleton $ f <$> implyProperty nameH e) obj else obj+             then KM.insert (toK nameJ) (vsingleton $ f <$> implyProperty nameH e) obj else obj         peElements = attributeSatisfies "class" $ any (\x → isPClass x || isEClass x) . T.split isSpace         resolveURI' = resolveURI $ baseUri settings addImpliedProperties _ _ v = v@@ -79,8 +92,8 @@   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+     then map (\(n, ts) → (toK n) .= [ addValue (fst $ head ts) (parseH settings e) (extractPropertyValue $ head ts) ]) propNames+     else map (\(n, ts) → (toK n) .= map extractPropertyValue ts) propNames  parseH ∷ Mf2ParserSettings → Element → Value parseH settings e =@@ -93,7 +106,7 @@   where childrenMf2 = map ((\x → addValue "p" x Null) . parseH settings) $ filter (not . isProperty) $ deduplicateElements allMf2Descendants         allMf2Descendants = filter (/= e) $ e ^.. cosmos . mf2Elements         -- we have to do all of this because multiple elements can become multiple properties (with overlap)-        properties = Object $ HMS.filter (not . emptyVal) properties'+        properties = Object $ KM.filter (not . emptyVal) properties'         (Object properties') = addImpliedProperties settings e $ object $ map mergeProps $ groupBy' fst properties''         properties'' = concatMap (parseProperty settings) $ removePropertiesOfNestedMicroformats allMf2Descendants $ filter (/= e) $ e ^.. cosmos . propertyElements @@ -101,9 +114,9 @@ parseMf2 ∷ Mf2ParserSettings → Element → Value parseMf2 settings rootEl = object [ "items" .= items, "rels" .= rels, "rel-urls" .= relUrls ]   where items = map (parseH settings') $ deduplicateElements $ rootEl' ^.. cosmos . mf2Elements-        rels = object $ map (\(r, es) → r .= map snd es) $ groupBy' fst $ expandSnd $ map (\e → (T.split isSpace (e ^. attr "rel"), resolveURI (baseUri settings') $ e ^. attr "href")) linkEls+        rels = object $ map (\(r, es) → (toK r) .= map snd es) $ groupBy' fst $ expandSnd $ map (\e → (T.split isSpace (e ^. attr "rel"), resolveURI (baseUri settings') $ e ^. attr "href")) linkEls         relUrls = object $ map relUrlObject linkEls-        relUrlObject e = resolveURI (baseUri settings') (e ^. attr "href") .= object (filter (not . emptyVal . snd) [+        relUrlObject e = toK (resolveURI (baseUri settings') (e ^. attr "href")) .= object (filter (not . emptyVal . snd) [             "rels" .= T.split isSpace (e ^. attr "rel")           , "text" .= fromMaybe Null (String <$> getInnerTextWithImgs e)           , linkAttr "type" "type" e
library/Data/Microformats2/Parser/UnsafeUtil.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Trustworthy, NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, QuasiQuotes #-}+{-# LANGUAGE Trustworthy, NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, QuasiQuotes, CPP #-}  module Data.Microformats2.Parser.UnsafeUtil (   module Data.Microformats2.Parser.UnsafeUtil@@ -14,7 +14,11 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Vector as V-import qualified Data.HashMap.Strict as HMS+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#endif import           Text.Regex.PCRE.Heavy import           Text.XML.Lens as X import           Text.HTML.DOM as X (sinkDoc, parseLBS)@@ -25,7 +29,7 @@ collapseWhitespace = gsub [re|(\s|&nbsp;)+|] (" " ∷ String)  emptyVal ∷ Value → Bool-emptyVal (Object o) = HMS.null o+emptyVal (Object o) = KM.null o emptyVal (Array v) = V.null v emptyVal (String s) = T.null s emptyVal Null = True
microformats2-parser.cabal view
@@ -1,12 +1,13 @@ name:            microformats2-parser-version:         1.0.2.0+version:         1.0.2.1 synopsis:        A Microformats 2 parser. description:     A parser for Microformats 2 (http://microformats.org/wiki/microformats2), a simple way to describe structured information in HTML. category:        Web-homepage:        https://github.com/unrelentingtech/microformats2-parser-author:          Greg V-copyright:       2015-2021 Greg V <greg@unrelenting.technology>-maintainer:      greg@unrelenting.technology+homepage:        https://codeberg.org/valpackett/microformats2-parser+bug-reports:     https://codeberg.org/valpackett/microformats2-parser/issues+author:          Val Packett+copyright:       2015-2022 Val Packett <val@packett.cool>+maintainer:      val@packett.cool license:         PublicDomain license-file:    UNLICENSE build-type:      Simple@@ -14,11 +15,11 @@ extra-source-files:     README.md tested-with:-    GHC == 8.10.4+    GHC == 9.0.2  source-repository head     type: git-    location: git://github.com/unrelentingtech/microformats2-parser.git+    location: https://codeberg.org/valpackett/microformats2-parser.git  library     build-depends:
test-suite/Data/Microformats2/ParserSpec.hs view
@@ -164,15 +164,15 @@   <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>+    <a href="https://val.packett.cool" rel=me>website</a>+    <p><span><a href="https://codeberg.org/valpackett" rel=me media=handheld hreflang=en>codeberg</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" ],+        "me": [ "https:\/\/codeberg.org\/valpackett", "https:\/\/val.packett.cool", "/atom.xml" ],         "alternate": [ "/atom.xml" ],         "prev": [ "/-1" ]     },@@ -181,12 +181,12 @@             "type": "application/atom+xml",             "rels": [ "alternate", "feed", "me" ]         },-        "https://twitter.com/myfreeweb": { -            "text": "twitter",+        "https://val.packett.cool": { +            "text": "website",             "rels": [ "me" ]         },-        "https://github.com/myfreeweb": { -            "text": "github",+        "https://codeberg.org/valpackett": { +            "text": "codeberg",             "rels": [ "me" ],             "media": "handheld",             "hreflang": "en"