diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,6 +12,7 @@ - resolves relative URLs (with support for the `` 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 - handles malformed HTML (the actual HTML parser is [tagstream-conduit]) +- also can convert to [JF2] - high performance - extensively tested @@ -21,6 +22,7 @@ [#IndieWeb]: http://indiewebcamp.com [sweetroll]: https://github.com/myfreeweb/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 ## [DEMO PAGE](https://unrelenting.technology/mf2/) diff --git a/library/Data/Microformats2/Jf2.hs b/library/Data/Microformats2/Jf2.hs new file mode 100644 --- /dev/null +++ b/library/Data/Microformats2/Jf2.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, OverloadedStrings #-} + +module Data.Microformats2.Jf2 (mf2ToJf2) where + +import Prelude.Compat +import Data.Maybe +import Data.Aeson.Lens +import qualified Data.HashMap.Strict as HMS +import qualified Data.Vector as V +import qualified Data.Text as T +import Data.Microformats2.Parser.UnsafeUtil + +mf2ToJf2 ∷ Value → Value +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 $ + 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 + _ → Object o + processContent x = x + flattenArr (Array v) | V.length v == 1 = V.head v + flattenArr x = x + processChildren x = x & key "children" . _Array . each %~ mf2ToJf2 + processItems x = x & key "items" . _Array . each %~ mf2ToJf2 + flattenItems x | x ^? key "items" . _Array . to V.length == Just 1 = fromMaybe x $ x ^? key "items" . nth 0 + flattenItems x = x +mf2ToJf2 x = x & _Array . each %~ mf2ToJf2 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 @@ -54,15 +54,19 @@ -- lens-aeson's 'key' doesn't add new keys :-( 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 "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 _ x _ = x addImpliedProperties ∷ Mf2ParserSettings → Element → Value → Value -addImpliedProperties settings e v@(Object o) = Object $ addIfNull "photo" "photo" resolveURI' $ addIfNull "url" "url" resolveURI' $ addIfNull "name" "name" id o +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) + 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 addImpliedProperties _ _ v = v diff --git a/microformats2-parser.cabal b/microformats2-parser.cabal --- a/microformats2-parser.cabal +++ b/microformats2-parser.cabal @@ -1,5 +1,5 @@ name: microformats2-parser -version: 1.0.1.8 +version: 1.0.1.9 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 @@ -14,7 +14,7 @@ extra-source-files: README.md tested-with: - GHC == 8.4.2 + GHC == 8.4.3 source-repository head type: git @@ -53,6 +53,7 @@ Data.Microformats2.Parser.Date Data.Microformats2.Parser.HtmlUtil Data.Microformats2.Parser.Util + Data.Microformats2.Jf2 other-modules: Data.Microformats2.Parser.UnsafeUtil ghc-options: -Wall @@ -107,4 +108,5 @@ Data.Microformats2.ParserSpec Data.Microformats2.Parser.PropertySpec Data.Microformats2.Parser.HtmlUtilSpec + Data.Microformats2.Jf2Spec type: exitcode-stdio-1.0 diff --git a/test-suite/Data/Microformats2/Jf2Spec.hs b/test-suite/Data/Microformats2/Jf2Spec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Data/Microformats2/Jf2Spec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, OverloadedStrings, UnicodeSyntax #-} + +module Data.Microformats2.Jf2Spec (spec) where + +import Prelude.Compat +import Test.Hspec hiding (shouldBe) +import Test.Hspec.Expectations.Pretty (shouldBe) +import TestCommon +import Data.Microformats2.Jf2 + +spec ∷ Spec +spec = do + describe "mf2ToJf2" $ do + it "converts microformats2 to JF2" $ do + mf2ToJf2 [json|{}|] `shouldBe` [json|{}|] + mf2ToJf2 [json|[{"type": ["h-meme", "lol"]}]|] `shouldBe` [json|[{"type": "meme"}]|] + mf2ToJf2 [json|{"type": ["h-meme", "lol"]}|] `shouldBe` [json|{"type": "meme"}|] + mf2ToJf2 [json|{"type": []}|] `shouldBe` [json|{"type": null}|] + mf2ToJf2 [json|{"type": ["h-ello"], "properties": {"category": ["Dank", "Memes"]}}|] + `shouldBe` [json|{"type": "ello", "category": ["Dank", "Memes"]}|] + mf2ToJf2 [json|{"type": ["h-ello"], "properties": {"category": ["Memes"]}}|] + `shouldBe` [json|{"type": "ello", "category": "Memes"}|] + mf2ToJf2 [json|{"type": ["h-entry"], "properties": {"category": ["Memes"], "author": [{"type": ["h-card"], "properties": {"name": ["Alice"]}}]}}|] + `shouldBe` [json|{"type": "entry", "category": "Memes", "author": {"type": "card", "name": "Alice"}}|] + mf2ToJf2 [json|{"type": ["h-entry"], "properties": {"category": ["Memes"], "author": ["Bob", {"type": ["h-card"], "properties": {"name": ["Alice"]}}]}}|] + `shouldBe` [json|{"type": "entry", "category": "Memes", "author": ["Bob", {"type": "card", "name": "Alice"}]}|] + mf2ToJf2 [json|{"type": ["h-entry"], "children": [{"type": ["h-card"], "properties": {"name": ["Alice"]}}]}|] + `shouldBe` [json|{"type": "entry", "children": [{"type": "card", "name": "Alice"}]}|] + mf2ToJf2 [json|{ "items": + [ + { + "type": [ "h-entry" ], + "properties": { + "author": [ + { + "type": [ "h-card" ], + "properties": { + "name": [ "A. Developer" ], + "url": [ "http://example.com" ] + }, + "value": "A. Developer" + } + ], + "name": [ "Hello World" ], + "summary": [ "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Vivamus imperdiet ultrices pulvinar." ], + "url": [ "http://example.com/2015/10/21" ], + "published": [ "2015-10-21T12:00:00-0700" ], + "content": [ + { + "html": "

Donec dapibus enim lacus, a vehicula magna bibendum non. Phasellus id lacinia felis, vitae pellentesque enim. Sed at quam dui. Suspendisse accumsan, est id pulvinar consequat, urna ex tincidunt enim, nec sodales lectus nulla et augue. Cras venenatis vehicula molestie. Donec sagittis elit orci, sit amet egestas ex pharetra in.

", + "value": "Donec dapibus enim lacus, a vehicula magna bibendum non. Phasellus id lacinia felis, vitae pellentesque enim. Sed at quam dui. Suspendisse accumsan, est id pulvinar consequat, urna ex tincidunt enim, nec sodales lectus nulla et augue. Cras venenatis vehicula molestie. Donec sagittis elit orci, sit amet egestas ex pharetra in." + } + ] + } + } + ] + }|] `shouldBe` [json|{ + "type": "entry", + "author": { + "type": "card", + "url": "http://example.com", + "name": "A. Developer" + }, + "url": "http://example.com/2015/10/21", + "published": "2015-10-21T12:00:00-0700", + "name": "Hello World", + "summary": "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Vivamus imperdiet ultrices pulvinar.", + "content": { + "html": "

Donec dapibus enim lacus, a vehicula magna bibendum non. Phasellus id lacinia felis, vitae pellentesque enim. Sed at quam dui. Suspendisse accumsan, est id pulvinar consequat, urna ex tincidunt enim, nec sodales lectus nulla et augue. Cras venenatis vehicula molestie. Donec sagittis elit orci, sit amet egestas ex pharetra in.

", + "text": "Donec dapibus enim lacus, a vehicula magna bibendum non. Phasellus id lacinia felis, vitae pellentesque enim. Sed at quam dui. Suspendisse accumsan, est id pulvinar consequat, urna ex tincidunt enim, nec sodales lectus nulla et augue. Cras venenatis vehicula molestie. Donec sagittis elit orci, sit amet egestas ex pharetra in." + } + }|] diff --git a/test-suite/Data/Microformats2/ParserSpec.hs b/test-suite/Data/Microformats2/ParserSpec.hs --- a/test-suite/Data/Microformats2/ParserSpec.hs +++ b/test-suite/Data/Microformats2/ParserSpec.hs @@ -77,13 +77,11 @@ "type": [ "h-area" ], "properties": {}, "shape": "circle", - "coords": "200,250,25", - "value": null + "coords": "200,250,25" }, { "type": [ "h-area" ], - "properties": {}, - "value": null + "properties": {} } ] } @@ -99,8 +97,7 @@ { "type": [ "h-entry" ], "properties": { - "content": [ { "value": "hello '<script></script>'", "html": "hello '<script></script>'" } ], - "name": [ "hello '<script></script>'" ] + "content": [ { "value": "hello '<script></script>'", "html": "hello '<script></script>'" } ] } } ], @@ -114,7 +111,6 @@ { "type": [ "h-parent" ], "properties": { - "name": [ "some html and props" ], "prop": [ { "type": [ "h-child" ], @@ -141,13 +137,11 @@ { "type": [ "h-parent" ], "properties": { - "name": [ "something\n a\n b" ], "outer": [ "something", "a" ], "inner": [ "some" ], "prop": [ { "type": [ "h-child" ], "properties": { - "name": [ "a" ], "aaa": [ "a" ] }, "value": "a" @@ -156,10 +150,8 @@ "children": [ { "type": [ "h-child" ], "properties": { - "name": [ "b" ], "bbb": [ "b" ] - }, - "value": "b" + } } ] } ],