diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,15 +1,19 @@ -# indieweb-algorithms [![Hackage](https://img.shields.io/hackage/v/indieweb-algorithms.svg?style=flat)](https://hackage.haskell.org/package/indieweb-algorithms) [![Build Status](https://img.shields.io/travis/myfreeweb/indieweb-algorithms.svg?style=flat)](https://travis-ci.org/myfreeweb/indieweb-algorithms) [![unlicense](https://img.shields.io/badge/un-license-green.svg?style=flat)](http://unlicense.org) +# indieweb-algorithms [![Hackage](https://img.shields.io/hackage/v/indieweb-algorithms.svg?style=flat)](https://hackage.haskell.org/package/indieweb-algorithms) [![unlicense](https://img.shields.io/badge/un-license-green.svg?style=flat)](https://unlicense.org) A collection of implementations of [IndieWeb]- and [Microformats 2]-related algorithms (based on [microformats2-parser] and [http-link-header]): - finding all microformats of a given type (while retaining the path to them), ie. flattening the tree -- discovering **[authorship](http://indiewebcamp.com/authorship)** of an `h-entry` -- discovering [Webmention](http://indiewebcamp.com/Webmention)/[Micropub](http://indiewebcamp.com/Micropub)/[IndieAuth](http://indiewebcamp.com/IndieAuth)/etc. **endpoints** (HTTP `Link` header, `a` and `link` tags with the `rel` attribute) +- discovering **[authorship](https://indieweb.org/authorship)** of an `h-entry` + - discovering the [representative h-card](https://microformats.org/wiki/representative-h-card-parsing) +- discovering [Webmention](https://indieweb.org/Webmention)/[Micropub](https://indieweb.org/Micropub)/[IndieAuth](https://indieweb.org/IndieAuth)/etc. **endpoints** (HTTP `Link` header, `a` and `link` tags with the `rel` attribute) +- parsing tweets on Twitter.com into microformats (like [php-mf2-shim](https://github.com/indieweb/php-mf2-shim)) +- detecting [post types](httpss://indieweb.org/posts#Kinds_of_Posts) +- converting microformats to Atom feeds -[#IndieWeb]: http://indiewebcamp.com -[Microformats 2]: http://microformats.org/wiki/microformats2 -[microformats2-parser]: https://github.com/myfreeweb/microformats2-parser -[http-link-header]: https://github.com/myfreeweb/http-link-header +[IndieWeb]: https://indieweb.org +[Microformats 2]: https://microformats.org/wiki/microformats2 +[microformats2-parser]: https://codeberg.org/valpackett/microformats2-parser +[http-link-header]: https://codeberg.org/valpackett/http-link-header ## Usage @@ -35,23 +39,14 @@ ```bash $ stack build -$ stack test && rm tests.tix +$ stack test -$ stack ghci --ghc-options="-fno-hpc" +$ stack ghci ``` [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/indieweb-algorithms/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/indieweb-algorithms.cabal b/indieweb-algorithms.cabal --- a/indieweb-algorithms.cabal +++ b/indieweb-algorithms.cabal @@ -1,24 +1,25 @@ name: indieweb-algorithms -version: 0.1.0 +version: 0.1.1 synopsis: A collection of implementations of IndieWeb algorithms. category: Web -homepage: https://github.com/myfreeweb/indieweb-algorithms -author: Greg V -copyright: 2015 Greg V -maintainer: greg@unrelenting.technology +homepage: https://codeberg.org/valpackett/indieweb-algorithms +bug-reports: https://codeberg.org/valpackett/indieweb-algorithms/issues +author: Val Packett +copyright: 2015-2017 Val Packett +maintainer: val@packett.cool license: PublicDomain license-file: UNLICENSE build-type: Simple -cabal-version: >= 1.18 +cabal-version: 1.18 extra-source-files: README.md tested-with: - GHC == 7.10.2 + GHC == 9.0.2 source-repository head type: git - location: git://github.com/myfreeweb/indieweb-algorithms.git + location: https://codeberg.org/valpackett/indieweb-algorithms.git library build-depends: @@ -29,21 +30,27 @@ , time , either , safe + , errors , containers , unordered-containers , vector , lens , aeson , lens-aeson + , xml-conduit + , xml-lens >= 0.2 + , xml-conduit-writer , data-default , network-uri , microformats2-parser - , http-link-header + , http-link-header >= 1.2.0 default-language: Haskell2010 exposed-modules: Data.IndieWeb.Authorship Data.IndieWeb.Endpoints + Data.IndieWeb.MicroformatsToAtom Data.IndieWeb.MicroformatsUtil + Data.IndieWeb.SiloToMicroformats ghc-options: -Wall hs-source-dirs: library @@ -57,20 +64,25 @@ , network-uri , hspec , hspec-expectations-pretty-diff + , lens , aeson + , lens-aeson + , xml-conduit , template-haskell , indieweb-algorithms , microformats2-parser , raw-strings-qq , aeson-qq , data-default + , http-link-header >= 1.2.0 default-language: Haskell2010 - ghc-options: -threaded -Wall -fhpc + ghc-options: -threaded -Wall hs-source-dirs: test-suite main-is: Spec.hs other-modules: TestCommon Data.IndieWeb.AuthorshipSpec Data.IndieWeb.EndpointsSpec + Data.IndieWeb.MicroformatsToAtomSpec Data.IndieWeb.MicroformatsUtilSpec type: exitcode-stdio-1.0 diff --git a/library/Data/IndieWeb/Authorship.hs b/library/Data/IndieWeb/Authorship.hs --- a/library/Data/IndieWeb/Authorship.hs +++ b/library/Data/IndieWeb/Authorship.hs @@ -2,27 +2,27 @@ module Data.IndieWeb.Authorship where -#if __GLASGOW_HASKELL__ < 709 +#if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Monad import Control.Monad.Trans.Maybe import Control.Lens import qualified Data.Text as T -import qualified Data.ByteString.Lazy as LB import qualified Data.Vector as V -import Data.Foldable (asum) +import Data.Foldable (asum, find) import Data.Maybe import Data.Aeson import Data.Aeson.Lens import Data.Microformats2.Parser import Data.IndieWeb.MicroformatsUtil +import Text.XML (Document) import Network.URI import Safe (headMay) -- | Finds the authors of an h-entry, discovering its authorship using the HTTP fetcher function from arguments. entryAuthors ∷ Monad μ ⇒ Mf2ParserSettings - → (URI → μ (Maybe LB.ByteString)) -- ^ the URI fetcher function + → (URI → μ (Maybe Document)) -- ^ the URI fetcher function → URI -- ^ the URI of the page the entry was extracted from → Value -- ^ the full Microformats 2 parse of the page as extracted by 'Data.Microformats2.Parser.parseMf2' → (Value, [Value]) -- ^ (the h-entry, [parent microformats]) as extracted by 'Data.IndieWeb.MicroformatsUtil.allMicroformatsOfType' @@ -42,9 +42,18 @@ entryAuthor = getAuthorProp entry feedAuthor = getAuthorProp =<< (headMay $ filter (isMf "h-feed") parents) getAuthorProp = (V.toList <$>) . (^? key "properties" . key "author" . _Array) - isMf t = (String t `V.elem`) . (fromMaybe V.empty) . (^? key "type" . _Array) cardFromUri uri = do -- TODO: only allow http(s) - html ← fetch $ uri `relativeTo` entryUri - -- TODO: representative h-card, not just first - return $ fmap fst $ headMay =<< allMicroformatsOfType "h-card" =<< parseMf2 mfSettings <$> documentRoot <$> parseLBS <$> html + let uri' = uri `relativeTo` entryUri + html ← fetch uri' + let mfSettings' = mfSettings { baseUri = Just uri' } + return $ representativeCard uri' =<< parseMf2 mfSettings' <$> documentRoot <$> html + +representativeCard ∷ URI → Value → Maybe Value +representativeCard uri mfRoot = asum [ matchingUidUrl, matchingRelMeUrl, matchingOnlyUrl ] + where matchingUidUrl = find (\c → any (== uri) (uris "url" c) && any (== uri) (uris "uid" c)) cards + matchingRelMeUrl = find (any (`elem` relMeUris) . uris "url") cards + matchingOnlyUrl = if length cards /= 1 then Nothing else find (any (== uri) . uris "url") cards + relMeUris = mapMaybe (parseURI . T.unpack) $ mfRoot ^.. key "rels" . key "me" . values . _String + uris k c = mapMaybe (parseURI . T.unpack) $ c ^.. key "properties" . key k . values . _String + cards = fmap fst $ fromMaybe [] $ allMicroformatsOfType "h-card" mfRoot diff --git a/library/Data/IndieWeb/Endpoints.hs b/library/Data/IndieWeb/Endpoints.hs --- a/library/Data/IndieWeb/Endpoints.hs +++ b/library/Data/IndieWeb/Endpoints.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-} +{-# LANGUAGE OverloadedStrings, UnicodeSyntax, CPP #-} module Data.IndieWeb.Endpoints where +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif import Control.Lens import Data.Maybe (catMaybes) import Data.List (nub) @@ -14,7 +17,7 @@ discoverEndpoints ∷ [T.Text]-- ^ the rels of the links you want to find (alternatives, like "webmention" and "http://webmention.org/") → Value -- ^ the full Microformats 2 parse of the page as extracted by 'Data.Microformats2.Parser.parseMf2' - → [Link] -- ^ the Link header as parsed by 'Network.HTTP.Link.parseLinkHeader' + → [Link URI] -- ^ the Link header as parsed by 'Network.HTTP.Link.parseLinkHeader' → [URI] discoverEndpoints rels mfRoot linkH = nub $ headerLinks ++ mfLinks where headerLinks = map href $ concat $ map (\r → filter (\(Link _ as) → (Rel, r) `elem` as) linkH) rels diff --git a/library/Data/IndieWeb/MicroformatsToAtom.hs b/library/Data/IndieWeb/MicroformatsToAtom.hs new file mode 100644 --- /dev/null +++ b/library/Data/IndieWeb/MicroformatsToAtom.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-} + +module Data.IndieWeb.MicroformatsToAtom ( + feedToAtom +, atomForEntry +, asForEntry +, el +, elA +, atom +, empty +) where + +import Control.Lens hiding (element) +import Control.Monad +import Control.Applicative ((<|>)) +import Data.Maybe +import Data.Text as T (Text, isPrefixOf, drop) +import Data.List (sortOn) +import Data.Aeson +import Data.Aeson.Lens +import Text.XML.Writer +import Text.XML +import Data.IndieWeb.MicroformatsUtil + +atom ∷ Text → Name +atom x = Name x (Just "http://www.w3.org/2005/Atom") Nothing + +el ∷ ToXML a ⇒ Text → a → XML +el x = element (atom x) + +elA ∷ ToXML a ⇒ Text → [(Name, Text)] → a → XML +elA x = elementA (atom x) + +firstStr ∷ AsValue s ⇒ Text → s → Maybe Text +firstStr k = (^? key "properties" . key k . nth 0 . _String) + +prop ∷ (t → XML) → Maybe t → XML +prop f (Just x) = f x +prop _ _ = empty + + +-- | Converts a givent Microformats 2 parse to an Atom feed. +feedToAtom ∷ XML → Value → Document +feedToAtom metaXml mfRoot = + document (atom "feed") $ do + metaXml + + let isAuthorOfFeed (_, p:_) = isMf "h-feed" p + isAuthorOfFeed _ = False + author = take 1 $ reverse $ sortOn isAuthorOfFeed $ fromMaybe [] $ allMicroformatsOfType "h-card" mfRoot + forM_ author $ \(card, _) → do + atomForCard card + prop (el "logo" . content) $ firstStr "photo" card + + let entries = fromMaybe [] $ allMicroformatsOfType "h-entry" mfRoot + forM_ entries $ \(entry, path) → + el "entry" $ atomForEntry entry + + +atomForCard ∷ Value → XML +atomForCard card = el "author" $ do + prop (el "name" . content) $ firstStr "name" card + prop (el "uri" . content) $ firstStr "url" card + prop (el "email" . content) $ (\x → if "mailto:" `T.isPrefixOf` x then T.drop 7 x else x) <$> firstStr "email" card + prop (\u → elA "link" [("rel", "alternate"), ("type", "text/html"), ("href", u)] empty) $ firstStr "url" card + prop (\u → elA "link" [("rel", "avatar"), ("href", u)] empty) $ firstStr "photo" card + asType "person" + +atomForEntry ∷ Value → XML +atomForEntry entry = do + prop (el "id" . content) $ firstStr "uid" entry <|> firstStr "url" entry + el "title" $ content $ if detectEntryType entry == Note then "" else (fromMaybe "" $ firstStr "name" entry) + prop (\u → elA "link" [("rel", "alternate"), ("type", "text/html"), ("href", u)] empty) $ firstStr "url" entry + prop (el "published" . content) $ firstStr "published" entry + prop (el "updated" . content) $ firstStr "updated" entry + prop (elA "content" [("type", "html")] . content) $ entry ^? key "properties" . key "content" . nth 0 . key "html" . _String + mapM_ atomForCard (entry ^.. key "properties" . key "author") + asForEntry entry + +asType, asVerb ∷ Text → XML +asType x = element (Name "object-type" (Just "http://activitystrea.ms/spec/1.0/") Nothing) $ content $ "http://activitystrea.ms/schema/1.0/" <> x +asVerb x = element (Name "verb" (Just "http://activitystrea.ms/spec/1.0/") Nothing) $ content x + + +thrInReplyTo ∷ Text → XML +thrInReplyTo x = elementA (Name "in-reply-to" (Just "http://purl.org/syndication/thread/1.0") Nothing) [("ref", x), ("href", x)] empty + +asForEntry ∷ Value → XML +asForEntry entry = asForEntry' (detectEntryType entry) entry + where asForEntry' Like e = asVerb "like" >> nest e "like-of" + asForEntry' RSVP e = fromMaybe empty (asVerb . ("rsvp-" <>) <$> e ^? key "properties" . key "rsvp" . nth 0 . _String) >> asType "event" + asForEntry' Checkin _ = asVerb "checkin" >> asType "place" + asForEntry' Repost e = asVerb "share" >> nest e "repost-of" + asForEntry' Reply e = asVerb "post" >> asType "comment" >> mapM_ thrInReplyTo (refUrls e "in-reply-to") + asForEntry' Bookmark _ = asVerb "post" >> asType "bookmark" + asForEntry' Article _ = asVerb "post" >> asType "article" + asForEntry' _ _ = asVerb "post" >> asType "note" + refUrls e k = e ^.. key "properties" . key k . values . key "properties" . key "url" . values . _String + nest e k = forM_ (e ^.. key "properties" . key k . values) $ \ee → do + asType "activity" + element (Name "object" (Just "http://activitystrea.ms/spec/1.0/") Nothing) $ atomForEntry ee diff --git a/library/Data/IndieWeb/MicroformatsUtil.hs b/library/Data/IndieWeb/MicroformatsUtil.hs --- a/library/Data/IndieWeb/MicroformatsUtil.hs +++ b/library/Data/IndieWeb/MicroformatsUtil.hs @@ -25,3 +25,25 @@ then (v, path) : acc' else acc' Just $ concatMap (findOfType [] []) items + +-- | Tests whether a given Value is of a given microformat type (e.g. h-entry, h-feed). +isMf ∷ T.Text → Value → Bool +isMf t = (String t `V.elem`) . (fromMaybe V.empty) . (^? key "type" . _Array) + +data EntryType = Repost | Like | Bookmark | RSVP | Reply | Checkin | Event | Audio | Photo | Article | Note + deriving (Show, Eq) + +-- | Detects a post type (https://indiewebcamp.com/posts#Kinds_of_Posts) +detectEntryType ∷ Value → EntryType +detectEntryType entry + | isJust (entry ^? key "properties" . key "repost-of" . nth 0) = Repost + | isJust (entry ^? key "properties" . key "like-of" . nth 0) = Like + | isJust (entry ^? key "properties" . key "bookmark-of" . nth 0) = Bookmark + | isJust (entry ^? key "properties" . key "rsvp" . nth 0) = RSVP + | isJust (entry ^? key "properties" . key "in-reply-to" . nth 0) = Reply + | isJust (entry ^? key "properties" . key "location" . nth 0) = Checkin + | isJust (entry ^? key "properties" . key "event" . nth 0) = Event + | isJust (entry ^? key "properties" . key "audio" . nth 0) = Audio + | isJust (entry ^? key "properties" . key "photo" . nth 0) = Photo + | isJust (entry ^? key "properties" . key "name" . nth 0) && (entry ^? key "properties" . key "name" . nth 0) /= (entry ^? key "properties" . key "content" . nth 0 . key "value") = Article + | otherwise = Note diff --git a/library/Data/IndieWeb/SiloToMicroformats.hs b/library/Data/IndieWeb/SiloToMicroformats.hs new file mode 100644 --- /dev/null +++ b/library/Data/IndieWeb/SiloToMicroformats.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-} + +module Data.IndieWeb.SiloToMicroformats where + +import Prelude +import Text.XML.Lens +import qualified Data.Text as T +import qualified Data.Text.Read as T +import Data.Aeson +import Data.Aeson.Lens (key) +import Data.Maybe +import Control.Applicative +import Control.Lens hiding ((.=)) +import Control.Error.Util (hush) +import Data.Time.Format +import Data.Time.Clock.POSIX +import Data.Microformats2.Parser.HtmlUtil +import Data.Microformats2.Parser.Property (getImgSrc) +import Data.Microformats2.Parser (extractProperty, Mf2ParserSettings) + +-- | Parses a twitter.com tweet into an h-entry value. +parseTwitter ∷ Mf2ParserSettings → Element → Maybe Value +parseTwitter s r = if isJust tweet && isJust username && isJust tweetText + then Just wrapper + else Nothing + where wrapper = object [ "type" .= [ String "h-entry" ] + , "properties" .= props ] + props = object [ "uid" .= [ permalink ] + , "url" .= [ permalink ] + , "content" .= [ tweetText ] + , "name" .= [ fromMaybe Null $ tweetText >>= (^? key "value") ] + , "published" .= [ str timestamp ] + , "author" .= [ author ] + , "comment" .= comments ] + author = object [ "type" .= [ String "h-card" ] + , "properties" .= object ([ "uid" .= [ profileUrl username ] + , "url" .= [ profileUrl username ] + , "name" .= [ str fullname ] + , "note" .= [ str bio ] + , "nickname" .= [ str username ] + , "photo" .= [ str avatar ] ] ++ pronouns) ] + comments = mapMaybe (parseTwitter s) $ r ^.. hasClass "permalink-replies" ... hasClass "tweet" + profileUrl (Just x) = String $ "https://twitter.com/" <> T.dropWhile (== '@') x + profileUrl _ = Null + tweetText = tweet >>= (^? hasClass "tweet-text") >>= return . extractProperty s "e" + fullname = tweet >>= (^? hasClass "fullname") >>= getInnerTextRaw + timestamp = tweet >>= (^? hasClass "_timestamp" . attr "data-time") >>= reformatTime + reformatTime x = T.pack <$> formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%S") <$> + posixSecondsToUTCTime <$> realToFrac <$> fst <$> (hush $ T.decimal x ∷ Maybe (Integer, T.Text)) + username = tweet >>= (^? hasClass "username") >>= getInnerTextRaw + avatar = tweet >>= (^? hasClass "avatar") >>= getImgSrc + permalink = tweet >>= (^? hasClass "tweet-timestamp") >>= return . extractProperty s "u" + bio = (r ^? hasClass "ProfileHeaderCard-bio" ) >>= getInnerTextRaw + pronouns = parsePronouns [] $ fromMaybe [] $ T.splitOn "/" <$> r ^? hasClass "ProfileSidebar" . cosmos . named "a" . attributeSatisfies "title" ("pronoun.is/" `T.isInfixOf`) . attr "title" + parsePronouns result (w : ww : "pronoun.is" : n : o : _ : p : _) = parsePronouns (("x-pronoun-posessive" .= [ String p ]) : result) (w : ww : "pronoun.is" : n : o : []) + parsePronouns result (w : ww : "pronoun.is" : n : o : _) = parsePronouns (("x-pronoun-oblique" .= [ String o ]) : result) (w : ww : "pronoun.is" : n : []) + parsePronouns result (_ : _ : "pronoun.is" : n : _) = ("x-pronoun-nominative" .= [ String n ]) : result + parsePronouns result _ = result + tweet = r ^? hasClass "permalink-tweet" <|> r ^? hasClass "tweet" + hasClass c = cosmos . attributeSatisfies "class" (c `T.isInfixOf`) + str (Just x) = String x + str _ = Null diff --git a/test-suite/Data/IndieWeb/AuthorshipSpec.hs b/test-suite/Data/IndieWeb/AuthorshipSpec.hs --- a/test-suite/Data/IndieWeb/AuthorshipSpec.hs +++ b/test-suite/Data/IndieWeb/AuthorshipSpec.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax #-} +{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax, CPP #-} module Data.IndieWeb.AuthorshipSpec (spec) where +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif import Test.Hspec hiding (shouldBe) import Test.Hspec.Expectations.Pretty (shouldBe) import TestCommon @@ -9,7 +12,8 @@ import qualified Data.ByteString.Lazy as LB import Data.Functor.Identity import Data.Maybe -import Data.Aeson +import Data.Aeson.Lens +import Control.Lens ((^?), _Just, _head) import Data.Microformats2.Parser import Data.IndieWeb.Authorship import Data.IndieWeb.MicroformatsUtil @@ -17,36 +21,40 @@ spec ∷ Spec spec = do describe "findAuthors" $ do - let o = object - mockFetch ∷ URI → Identity (Maybe LB.ByteString) + let mockFetch ∷ URI → Identity (Maybe LB.ByteString) mockFetch "http://direct" = return $ Just [xml|

Author from Direct!|] mockFetch "http://link" = return $ Just [xml|
http://author/page|] + mockFetch "http://link-relme" = return $ Just [xml|
http://author/page-relme|] + mockFetch "http://link-only-url" = return $ Just [xml|
http://author/page-only-url|] + mockFetch "http://link-not-only-url" = return $ Just [xml|
http://author/page-not-only-url|] mockFetch "http://rel" = return $ Just [xml|
|] mockFetch "http://author/page/link-relative" = return $ Just [xml|
/page|] mockFetch "http://feed" = return $ Just [xml|

Author from Feed!

|] mockFetch "http://feed/link" = return $ Just [xml|
http://author/page
|] - mockFetch "http://author/page" = return $ Just [xml|

Author from Page!|] + mockFetch "http://author/page" = return $ Just [xml|

Author from Page!|] + mockFetch "http://author/page-relme" = return $ Just [xml|

Author from Page-relme!|] + mockFetch "http://author/page-only-url" = return $ Just [xml|

Author from Page-only-url!|] + mockFetch "http://author/page-not-only-url" = return $ Just [xml|

Author from Page-not-only-url!

Author from Page-not-only-url!|] mockFetch _ = return Nothing rE u = let mf = parseMf2 def . documentRoot . parseLBS . fromMaybe "" . runIdentity $ mockFetch u in - runIdentity . entryAuthors def mockFetch u mf . head . fromJust $ allMicroformatsOfType "h-entry" mf - card n = o [ "value" .= String n - , "type" .= [ String "h-card" ] - , "properties" .= o [ "name" .= [ String n ] ] ] - card' n = o [ "type" .= [ String "h-card" ] - , "properties" .= o [ "name" .= [ String n ] ] ] + runIdentity . entryAuthors def (\x → mockFetch x >>= \y → return $ parseLBS <$> y) u mf . head . fromJust $ allMicroformatsOfType "h-entry" mf + firstName = _Just . _head . key "properties" . key "name" . nth 0 . _String it "finds the author h-cards embedded in the h-entry" $ do - rE "http://direct" `shouldBe` Just [ card "Author from Direct!" ] + rE "http://direct" ^? firstName `shouldBe` Just "Author from Direct!" it "finds the author h-cards embedded in the h-feed parent of h-entry" $ do - rE "http://feed" `shouldBe` Just [ card "Author from Feed!" ] + rE "http://feed" ^? firstName `shouldBe` Just "Author from Feed!" it "finds the author h-cards linked from the h-entry" $ do - rE "http://link" `shouldBe` Just [ card' "Author from Page!" ] + rE "http://link" ^? firstName `shouldBe` Just "Author from Page!" + rE "http://link-relme" ^? firstName `shouldBe` Just "Author from Page-relme!" + rE "http://link-only-url" ^? firstName `shouldBe` Just "Author from Page-only-url!" + rE "http://link-not-only-url" ^? firstName `shouldBe` Nothing it "finds the author h-cards linked from the h-feed parent of h-entry" $ do - rE "http://feed/link" `shouldBe` Just [ card' "Author from Page!" ] + rE "http://feed/link" ^? firstName `shouldBe` Just "Author from Page!" it "finds the author h-cards linked as rel=author" $ do - rE "http://rel" `shouldBe` Just [ card' "Author from Page!" ] - rE "http://author/page/link-relative" `shouldBe` Just [ card' "Author from Page!" ] + rE "http://rel" ^? firstName `shouldBe` Just "Author from Page!" + rE "http://author/page/link-relative" ^? firstName `shouldBe` Just "Author from Page!" diff --git a/test-suite/Data/IndieWeb/MicroformatsToAtomSpec.hs b/test-suite/Data/IndieWeb/MicroformatsToAtomSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Data/IndieWeb/MicroformatsToAtomSpec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax #-} + +module Data.IndieWeb.MicroformatsToAtomSpec where + +import Test.Hspec +import TestCommon +import Text.XML +import Data.Text.Lazy (Text, unpack) +import Data.Aeson hiding (json) +import Data.IndieWeb.MicroformatsToAtom + +ex ∷ Value +ex = [json|{ + "items": [ + { + "type": [ "h-entry" ], + "properties": { + "published": [ "2016-03-15T21:03:52.570481000000Z" ], + "url": [ "https://unrelenting.technology/notes/2016-03-15-21-03-52" ], + "content": [ { "value": "Updated the build of sweetroll on this website", "html": " \u003cp\u003eUpdated the build of \u003ca href=\"https://codeberg.org/valpackett/sweetroll\"\u003esweetroll\u003c/a\u003e on this website \u003c/p\u003e\u003ca href=\"https://brid.gy/publish/twitter\"\u003e\u003c/a\u003e " } ], + "name": [ "Updated the build of sweetroll on this website" ] + } + }, + { + "type": [ "h-entry" ], + "properties": { + "published": [ "2016-03-14T22:23:11.089Z" ], + "url": [ "https://unrelenting.technology/responses/reply" ], + "content": [ { "value": "(Reply test)", "html": " \u003cp\u003e(Reply test)\u003c/p\u003e" } ], + "name": [ "(Reply test)" ], + "in-reply-to": [ + { + "type": [ "h-entry" ], + "properties": { + "url": [ "https://unrelenting.technology/responses/parent" ] + } + } + ] + } + }, + { + "type": [ "h-entry" ], + "properties": { + "published": [ "2016-03-14T22:23:11.089Z" ], + "url": [ "https://unrelenting.technology/notes/repost" ], + "content": [ { "value": "(Repost test)", "html": " \u003cp\u003e(Repost test)\u003c/p\u003e" } ], + "name": [ "(Repost test)" ], + "repost-of": [ + { + "type": [ "h-entry" ], + "properties": { + "published": [ "2016-03-14T22:23:11.089Z" ], + "url": [ "https://unrelenting.technology/notes/original" ], + "content": [ { "value": "(Repost original)", "html": " \u003cp\u003e(Repost original)\u003c/p\u003e" } ], + "name": [ "(Repost original)" ] + } + } + ] + } + }, + { + "type": [ "h-card" ], + "properties": { + "name": [ "Greg" ], + "email": [ "mailto:val@packett.cool" ], + "photo": [ "https://www.gravatar.com/avatar/5e7281cf21d93c6a238749790afe086c" ], + "note": [ "My name's Greg. I do a lot of software development (mostly web and mobile), some design and photography. my.pronoun.is/they/them." ], + "url": [ "https://unrelenting.technology/" ], + "key": [ "https://unrelenting.technology/pub/3B011BAF.asc" ], + "x-pronoun-oblique": [ "them" ], + "x-pronoun-nominative": [ "they" ] + } + } + ], + "rels": { + "home": [ "https://unrelenting.technology/" ], + "author": [ "https://unrelenting.technology/" ] + }, + "rel-urls": { + "https://unrelenting.technology/": { "text": "Greg", "rels": [ "me", "home", "author" ] } + } +} |] + +exAtom ∷ Text +exAtom = [xml| + + + + Greg + https://unrelenting.technology/ + val@packett.cool + + + http://activitystrea.ms/schema/1.0/person + + https://www.gravatar.com/avatar/5e7281cf21d93c6a238749790afe086c + + https://unrelenting.technology/notes/2016-03-15-21-03-52 + Updated the build of sweetroll on this website + + 2016-03-15T21:03:52.570481000000Z + \u003cp\u003eUpdated the build of \u003ca href="https://codeberg.org/valpackett/sweetroll"\u003esweetroll\u003c/a\u003e on this website \u003c/p\u003e\u003ca href="https://brid.gy/publish/twitter"\u003e\u003c/a\u003e + post + http://activitystrea.ms/schema/1.0/note + + + https://unrelenting.technology/responses/reply + (Reply test) + + 2016-03-14T22:23:11.089Z + \u003cp\u003e(Reply test)\u003c/p\u003e + post + http://activitystrea.ms/schema/1.0/comment + + + + https://unrelenting.technology/notes/repost + (Repost test) + + 2016-03-14T22:23:11.089Z + \u003cp\u003e(Repost test)\u003c/p\u003e + share + + http://activitystrea.ms/schema/1.0/activity + + https://unrelenting.technology/notes/original + (Repost original) + + 2016-03-14T22:23:11.089Z + \u003cp\u003e(Repost original)\u003c/p\u003e + post + http://activitystrea.ms/schema/1.0/note + + +|] + +spec ∷ Spec +spec = do + describe "feedToAtom" $ do + it "converts h-entries to an Atom feed" $ do + --feedToAtom empty ex `shouldBe` parseText_ def exAtom + --putStrLn $ unpack $ renderText def $ feedToAtom empty ex + pendingWith "XML comparison sucks because of whitespace nodes and namespaces"