diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,4 @@ [![Hackage](https://img.shields.io/hackage/v/microformats2-parser.svg?style=flat)](https://hackage.haskell.org/package/microformats2-parser) -[![Build Status](https://img.shields.io/travis/myfreeweb/microformats2-parser.svg?style=flat)](https://travis-ci.org/myfreeweb/microformats2-parser) [![unlicense](https://img.shields.io/badge/un-license-green.svg?style=flat)](http://unlicense.org) # microformats2-parser @@ -19,11 +18,11 @@ 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 +[#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/myfreeweb/http-link-header +[http-link-header]: https://github.com/unrelentingtech/http-link-header ## [DEMO PAGE](https://unrelenting.technology/mf2/) @@ -71,11 +70,11 @@ Please feel free to submit pull requests! -By participating in this project you agree to follow the [Contributor Code of Conduct](http://contributor-covenant.org/version/1/4/) and to release your contributions under the Unlicense. +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/myfreeweb/microformats2-parser/graphs/contributors). +[The list of contributors is available on GitHub](https://github.com/unrelentingtech/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). +For more information, please refer to the `UNLICENSE` file or [unlicense.org](https://unlicense.org). diff --git a/executable/Lambda.hs b/executable/Lambda.hs new file mode 100644 --- /dev/null +++ b/executable/Lambda.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-} +module Main (main) where + +import Aws.Lambda +import Aws.Lambda.Wai +import WebApp + +main ∷ IO () +main = runWaiAsProxiedHttpLambda defaultDispatcherOptions (ignoreALBPathPart "mf2") (HandlerName "mf2") app diff --git a/executable/Main.hs b/executable/Main.hs deleted file mode 100644 --- a/executable/Main.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax #-} - -module Main (main) where - -import Prelude.Compat -import Data.Microformats2.Parser -import Data.Aeson.Encode.Pretty -import Data.Aeson.Types (object) -import Data.Default -import qualified Data.Text.Lazy as TL -import Network.Wai.Cli -import Network.Wai.Middleware.Autohead -import Network.URI (parseURI) -import Web.Scotty hiding (html) -import Text.Blaze.Html5 as H hiding (main, param, object, base) -import Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html.Renderer.Utf8 (renderHtml) - - -exampleValue = "

17 Austerstræti Reykjavík Iceland 107

Mitchell Baker (Mozilla Foundation)

Microformats are amazing

Published by W. Developer on

In which I extoll the virtues of using microformats.

Blah blah blah

AUTHOR: TITLE " - -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, 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 - 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 "Notes:" - ul $ 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!" - footer $ do - a ! href "https://unrelenting.technology" ! rel "author" $ "unrelenting.technology" - -app = scottyApp $ do - middleware autohead - - get "/" $ do - setHeader "Content-Type" "text/html; charset=utf-8" - raw $ renderHtml $ homePage exampleValue - - get "/parse.json" $ do - setHeader "Access-Control-Allow-Origin" "*" - json $ object [] - - post "/parse.json" $ do - hsrc ← param "html" - base ← param "base" `rescue` (\_ → return "") - setHeader "Content-Type" "application/json; charset=utf-8" - setHeader "Access-Control-Allow-Origin" "*" - let root = documentRoot $ parseLBS hsrc - raw $ encodePretty $ parseMf2 (def { baseUri = parseURI base }) root - -main = defWaiMain =<< app diff --git a/executable/Server.hs b/executable/Server.hs new file mode 100644 --- /dev/null +++ b/executable/Server.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} +module Main (main) where + +import Network.Wai.Cli +import WebApp + +main = defWaiMain =<< app diff --git a/executable/WebApp.hs b/executable/WebApp.hs new file mode 100644 --- /dev/null +++ b/executable/WebApp.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, TemplateHaskell #-} + +module WebApp (app) where + +import Prelude.Compat +import Data.Microformats2.Parser +import Data.Microformats2.Jf2 +import Data.Aeson.Encode.Pretty +import Data.Aeson.Types (object) +import Data.Default +import qualified Data.Text.Lazy as TL +import Network.Wai (Application) +import Network.Wai.Middleware.Autohead +import Network.URI (parseURI) +import Web.Scotty hiding (html) +import Text.Blaze.Html5 as H hiding (main, param, object, base) +import Text.Blaze.Html5.Attributes as A hiding (id) +import Text.Blaze.Html.Renderer.Utf8 (renderHtml) +import GitHash + + +exampleValue ∷ TL.Text +exampleValue = "

17 Austerstræti Reykjavík Iceland 107

Mitchell Baker (Mozilla Foundation)

Microformats are amazing

Published by W. Developer on

In which I extoll the virtues of using microformats.

Blah blah blah

AUTHOR: TITLE " + +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, 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.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://hackage.haskell.org/package/microformats2-parser" $ img ! alt "Hackage" ! src "https://img.shields.io/hackage/v/microformats2-parser.svg?style=flat" + " " + a ! href "https://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 "Notes:" + ul $ do + li "this demo page uses the Sanitize mode for e-*" + li $ do + a ! href "https://enable-cors.org" $ "CORS is enabled" + " on the endpoint (POST parse.json, form-urlencoded, 'html' and 'base' parameter)" + 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" + H.label $ do + input ! name "jf2" ! type_ "checkbox" + "Return " + a ! href "https://indieweb.org/jf2" $ "jf2" + " instead of full MF2 JSON" + button "Parse!" + footer $ do + let gi = $$tGitInfoCwd + p $ do + "Version: " + a ! href (toValue $ "https://github.com/unrelentingtech/microformats2-parser/commit/" <> giHash gi) $ toMarkup $ take 12 $ giHash gi + " (" + toMarkup $ giCommitDate gi + ")" + a ! href "https://unrelenting.technology" ! rel "author" $ "unrelenting.technology" + +app ∷ IO Application +app = scottyApp $ do + middleware autohead + + get "/" $ do + setHeader "Content-Type" "text/html; charset=utf-8" + raw $ renderHtml $ homePage exampleValue + + get "/parse.json" $ do + setHeader "Access-Control-Allow-Origin" "*" + json $ object [] + + post "/parse.json" $ do + hsrc ← param "html" + base ← param "base" `rescue` (\_ → return "") + jf2 ← param "jf2" `rescue` (\_ → return ("" ∷ TL.Text)) + setHeader "Content-Type" "application/json; charset=utf-8" + setHeader "Access-Control-Allow-Origin" "*" + let root = documentRoot $ parseLBS hsrc + raw $ encodePretty $ (if jf2 /= "" then mf2ToJf2 else id) $ parseMf2 (def { baseUri = parseURI base }) root diff --git a/library/Data/Microformats2/Jf2.hs b/library/Data/Microformats2/Jf2.hs --- a/library/Data/Microformats2/Jf2.hs +++ b/library/Data/Microformats2/Jf2.hs @@ -3,6 +3,7 @@ module Data.Microformats2.Jf2 (mf2ToJf2) where import Prelude.Compat +import Control.Lens import Data.Maybe import Data.Aeson.Lens import qualified Data.HashMap.Strict as HMS diff --git a/library/Data/Microformats2/Parser.hs b/library/Data/Microformats2/Parser.hs --- a/library/Data/Microformats2/Parser.hs +++ b/library/Data/Microformats2/Parser.hs @@ -64,7 +64,7 @@ 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 addIfNullAndNoOthers nameJ nameH f obj = - if isNothing (v ^? key nameJ) && isNothing (v ^? key "children") && isNothing (e ^? plate . entire . peElements) + 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 peElements = attributeSatisfies "class" $ any (\x → isPClass x || isEClass x) . T.split isSpace resolveURI' = resolveURI $ baseUri settings @@ -72,7 +72,7 @@ removePropertiesOfNestedMicroformats ∷ [Element] → [Element] → [Element] removePropertiesOfNestedMicroformats nmf2s = filter (not . isNested) - where isNested e = any (\e' → e `elem` filter (/= e') (e' ^.. entire)) nmf2s + where isNested e = any (\e' → e `elem` filter (/= e') (e' ^.. cosmos)) nmf2s parseProperty ∷ Mf2ParserSettings → Element → [Pair] parseProperty settings e = @@ -88,19 +88,19 @@ "type" .= filter isMf2Class (classes e) , "properties" .= properties , "children" .= childrenMf2 - , "shape" .= fromMaybe Null (String <$> e ^? el "area" . attr "shape") - , "coords" .= fromMaybe Null (String <$> e ^? el "area" . attr "coords") ] + , "shape" .= fromMaybe Null (String <$> e ^? named "area" . attr "shape") + , "coords" .= fromMaybe Null (String <$> e ^? named "area" . attr "coords") ] where childrenMf2 = map ((\x → addValue "p" x Null) . parseH settings) $ filter (not . isProperty) $ deduplicateElements allMf2Descendants - allMf2Descendants = filter (/= e) $ e ^.. entire . mf2Elements + 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' (Object properties') = addImpliedProperties settings e $ object $ map mergeProps $ groupBy' fst properties'' - properties'' = concatMap (parseProperty settings) $ removePropertiesOfNestedMicroformats allMf2Descendants $ filter (/= e) $ e ^.. entire . propertyElements + properties'' = concatMap (parseProperty settings) $ removePropertiesOfNestedMicroformats allMf2Descendants $ filter (/= e) $ e ^.. cosmos . propertyElements -- | 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 + 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 relUrls = object $ map relUrlObject linkEls relUrlObject e = resolveURI (baseUri settings') (e ^. attr "href") .= object (filter (not . emptyVal . snd) [ @@ -110,9 +110,9 @@ , linkAttr "media" "media" e , linkAttr "hreflang" "hreflang" e ]) linkAttr nameJ nameH e = nameJ .= fromMaybe Null (String <$> e ^? attr nameH) - linkEls = filter (isJust . (^? attr "href")) $ filter (isJust . (^? attr "rel")) $ rootEl' ^.. entire . els [ "a", "link" ] + linkEls = filter (isJust . (^? attr "href")) $ filter (isJust . (^? attr "rel")) $ rootEl' ^.. cosmos . els [ "a", "link" ] -- Obligatory WTF comment about base[href] being relative to the URI the page was requested from! - settings' = settings { baseUri = case (baseUri settings, parseURIReference =<< T.unpack <$> (rootEl' ^? entire . el "base" . attr "href")) of + settings' = settings { baseUri = case (baseUri settings, parseURIReference =<< T.unpack <$> (rootEl' ^? cosmos . named "base" . attr "href")) of (Just sU, Just tU) → Just (tU `relativeTo` sU) (Just sU, Nothing) → Just sU (Nothing, Just tU) → Just tU diff --git a/library/Data/Microformats2/Parser/HtmlUtil.hs b/library/Data/Microformats2/Parser/HtmlUtil.hs --- a/library/Data/Microformats2/Parser/HtmlUtil.hs +++ b/library/Data/Microformats2/Parser/HtmlUtil.hs @@ -85,7 +85,7 @@ deduplicateElements ∷ [Element] → [Element] deduplicateElements es = filter (not . isNested) es - where isNested e = any (\e' → e `elem` filter (/= e') (e' ^.. entire)) es + where isNested e = any (\e' → e `elem` filter (/= e') (e' ^.. cosmos)) es -- not the fastest function I guess... escapeHtml ∷ Text → Text diff --git a/library/Data/Microformats2/Parser/Property.hs b/library/Data/Microformats2/Parser/Property.hs --- a/library/Data/Microformats2/Parser/Property.hs +++ b/library/Data/Microformats2/Parser/Property.hs @@ -6,6 +6,7 @@ import Prelude.Compat import qualified Data.Text as T import Data.Text (Text) +import Data.CaseInsensitive (CI) import Data.Char (isSpace) import Data.Foldable (asum) import qualified Data.Map as M @@ -43,21 +44,21 @@ getOnlyChildren ∷ Element → [Element] getOnlyChildren e = if lengthOf plate e == 1 then e ^.. plate else [] -getOnlyChild, getOnlyOfType ∷ Name → Element → Maybe Element +getOnlyChild, getOnlyOfType ∷ CI Text → Element → Maybe Element getOnlyChild n e = if' (fromMaybe False $ not <$> isProperty <$> r) $ r - where r = if' (lengthOf plate e == 1) $ e ^? plate . el n + where r = if' (lengthOf plate e == 1) $ e ^? plate . named n getOnlyOfType n e = if' (fromMaybe False $ not <$> isProperty <$> r) $ r - where r = if' (lengthOf (plate . el n) e == 1) $ e ^? plate . el n + where r = if' (lengthOf (plate . named n) e == 1) $ e ^? plate . named 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" +getAbbrTitle e = e ^. named "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" +getImgSrc e = e ^. named "img" . attribute "src" +getObjectData e = e ^. named "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" @@ -74,8 +75,8 @@ extractValueClassPattern fs e = if' (isJust $ e ^? valueParts) extractValueParts where extractValueParts = Just . catMaybes $ e ^.. valueParts . to extractValuePart extractValuePart e' = asum $ fs <*> pure e' - valueParts ∷ Applicative φ => (Element → φ Element) → Element → φ Element - valueParts = entire . hasOneClass ["value", "value-title"] + valueParts ∷ (Applicative φ, Contravariant φ) => (Element → φ Element) → Element → φ Element + valueParts = cosmos . hasOneClass ["value", "value-title"] extractValueClassPatternConcat ∷ [Element → Maybe Text] → Element → Maybe Text extractValueClassPatternConcat fs e = T.concat <$> extractValueClassPattern fs e diff --git a/library/Data/Microformats2/Parser/UnsafeUtil.hs b/library/Data/Microformats2/Parser/UnsafeUtil.hs --- a/library/Data/Microformats2/Parser/UnsafeUtil.hs +++ b/library/Data/Microformats2/Parser/UnsafeUtil.hs @@ -6,6 +6,7 @@ ) where import Prelude.Compat +import Control.Lens as X hiding (re, (.=)) import Data.Aeson import Data.Aeson.Types as X import Data.Default as X @@ -15,7 +16,7 @@ import qualified Data.Vector as V import qualified Data.HashMap.Strict as HMS import Text.Regex.PCRE.Heavy -import Text.XML.Lens as X hiding (re, (.=)) +import Text.XML.Lens as X import Text.HTML.DOM as X (sinkDoc, parseLBS) import Text.Blaze import Text.Blaze.Renderer.Text diff --git a/microformats2-parser.cabal b/microformats2-parser.cabal --- a/microformats2-parser.cabal +++ b/microformats2-parser.cabal @@ -1,11 +1,11 @@ name: microformats2-parser -version: 1.0.1.9 +version: 1.0.2.0 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/myfreeweb/microformats2-parser +homepage: https://github.com/unrelentingtech/microformats2-parser author: Greg V -copyright: 2015-2018 Greg V +copyright: 2015-2021 Greg V maintainer: greg@unrelenting.technology license: PublicDomain license-file: UNLICENSE @@ -14,11 +14,11 @@ extra-source-files: README.md tested-with: - GHC == 8.4.3 + GHC == 8.10.4 source-repository head type: git - location: git://github.com/myfreeweb/microformats2-parser.git + location: git://github.com/unrelentingtech/microformats2-parser.git library build-depends: @@ -27,6 +27,7 @@ , transformers , text , bytestring + , case-insensitive , time , either , safe @@ -36,6 +37,7 @@ , vector , aeson , aeson-qq + , lens , lens-aeson , data-default , html-conduit @@ -64,6 +66,7 @@ base >= 4.7.0.0 && < 5 , base-compat >= 0.8.0 , options + , wai , wai-cli , wai-extra , network @@ -75,11 +78,39 @@ , aeson-pretty , blaze-html , blaze-markup + , githash , microformats2-parser default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -qa -qm" hs-source-dirs: executable - main-is: Main.hs + main-is: Server.hs + other-modules: WebApp + +executable microformats2-parser-lambda + build-depends: + base >= 4.7.0.0 && < 5 + , base-compat >= 0.8.0 + , options + , aws-lambda-haskell-runtime + , aws-lambda-haskell-runtime-wai + , wai + , wai-extra + , network + , network-uri + , data-default + , text + , scotty + , aeson + , aeson-pretty + , blaze-html + , blaze-markup + , githash + , microformats2-parser + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -qa -qm" + hs-source-dirs: executable + main-is: Lambda.hs + other-modules: WebApp test-suite tests build-depends: