indieweb-algorithms (empty) → 0.1.0
raw patch · 11 files changed
+402/−0 lines, 11 filesdep +aesondep +aeson-qqdep +base
Dependencies added: aeson, aeson-qq, base, bytestring, containers, data-default, either, hspec, hspec-expectations-pretty-diff, http-link-header, indieweb-algorithms, lens, lens-aeson, microformats2-parser, mtl, network-uri, raw-strings-qq, safe, template-haskell, text, time, transformers, unordered-containers, vector
Files
- README.md +57/−0
- UNLICENSE +24/−0
- indieweb-algorithms.cabal +76/−0
- library/Data/IndieWeb/Authorship.hs +50/−0
- library/Data/IndieWeb/Endpoints.hs +22/−0
- library/Data/IndieWeb/MicroformatsUtil.hs +27/−0
- test-suite/Data/IndieWeb/AuthorshipSpec.hs +52/−0
- test-suite/Data/IndieWeb/EndpointsSpec.hs +31/−0
- test-suite/Data/IndieWeb/MicroformatsUtilSpec.hs +36/−0
- test-suite/Spec.hs +1/−0
- test-suite/TestCommon.hs +26/−0
+ README.md view
@@ -0,0 +1,57 @@+# indieweb-algorithms [](https://hackage.haskell.org/package/indieweb-algorithms) [](https://travis-ci.org/myfreeweb/indieweb-algorithms) [](http://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)++[#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++## Usage++### Endpoints++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Network.HTTP.Link+import Data.Default+import Data.Maybe+import Data.Microformats2.Parser+import Data.IndieWeb.Endpoints++discoverEndpoints [ "micropub" ] (parseMf2 def $ documentRoot $ parseLBS "<link rel=micropub href='http://example.com/micropub2'>...") (fromMaybe [] $ parseLinkHeader "<http://example.com/micropub>; rel=\"micropub\"")+```++## Development++Use [stack] to build. +Use ghci to run tests quickly with `:test` (see the `.ghci` file).++```bash+$ stack build++$ stack test && rm tests.tix++$ stack ghci --ghc-options="-fno-hpc"+```++[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).
+ UNLICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <http://unlicense.org/>
+ indieweb-algorithms.cabal view
@@ -0,0 +1,76 @@+name: indieweb-algorithms+version: 0.1.0+synopsis: A collection of implementations of IndieWeb algorithms.+category: Web+homepage: https://github.com/myfreeweb/indieweb-algorithms+author: Greg V+copyright: 2015 Greg V <greg@unrelenting.technology>+maintainer: greg@unrelenting.technology+license: PublicDomain+license-file: UNLICENSE+build-type: Simple+cabal-version: >= 1.18+extra-source-files:+ README.md+tested-with:+ GHC == 7.10.2+++source-repository head+ type: git+ location: git://github.com/myfreeweb/indieweb-algorithms.git++library+ build-depends:+ base >= 4.0.0.0 && < 5+ , transformers+ , text+ , bytestring+ , time+ , either+ , safe+ , containers+ , unordered-containers+ , vector+ , lens+ , aeson+ , lens-aeson+ , data-default+ , network-uri+ , microformats2-parser+ , http-link-header+ default-language: Haskell2010+ exposed-modules:+ Data.IndieWeb.Authorship+ Data.IndieWeb.Endpoints+ Data.IndieWeb.MicroformatsUtil+ ghc-options: -Wall+ hs-source-dirs: library++test-suite tests+ build-depends:+ base >= 4.0.0.0 && < 5+ , mtl+ , time+ , text+ , bytestring+ , network-uri+ , hspec+ , hspec-expectations-pretty-diff+ , aeson+ , template-haskell+ , indieweb-algorithms+ , microformats2-parser+ , raw-strings-qq+ , aeson-qq+ , data-default+ default-language: Haskell2010+ ghc-options: -threaded -Wall -fhpc+ hs-source-dirs: test-suite+ main-is: Spec.hs+ other-modules:+ TestCommon+ Data.IndieWeb.AuthorshipSpec+ Data.IndieWeb.EndpointsSpec+ Data.IndieWeb.MicroformatsUtilSpec+ type: exitcode-stdio-1.0
+ library/Data/IndieWeb/Authorship.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings, UnicodeSyntax, CPP, FlexibleContexts #-}++module Data.IndieWeb.Authorship where++#if __GLASGOW_HASKELL__ < 709+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.Maybe+import Data.Aeson+import Data.Aeson.Lens+import Data.Microformats2.Parser+import Data.IndieWeb.MicroformatsUtil+import Network.URI+import Safe (headMay)++-- | Finds the authors of an h-entry, discovering its authorship <http://indiewebcamp.com/authorship> using the HTTP fetcher function from arguments.+entryAuthors ∷ Monad μ ⇒ Mf2ParserSettings+ → (URI → μ (Maybe LB.ByteString)) -- ^ 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'+ → μ (Maybe [Value])+entryAuthors mfSettings fetch entryUri mfRoot (entry, parents) = runMaybeT $ asum $ map MaybeT [ embeddedCards, relCards ]+ where fetchIfLink v+ | isMf "h-card" v = return $ Just v+ | otherwise = case (T.unpack <$> v ^? _String) >>= parseURIReference of+ Nothing → return $ Just v+ Just uri → cardFromUri uri+ embeddedCards = case asum [ entryAuthor, feedAuthor ] of+ Nothing → return Nothing+ Just authors → liftM (Just . catMaybes) $ mapM fetchIfLink authors+ relCards = case V.toList <$> mfRoot ^? key "rels" . key "author" . _Array of+ Nothing → return Nothing+ Just rels → liftM (Just . catMaybes) $ mapM fetchIfLink rels+ 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
+ library/Data/IndieWeb/Endpoints.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-}++module Data.IndieWeb.Endpoints where++import Control.Lens+import Data.Maybe (catMaybes)+import Data.List (nub)+import Data.Aeson+import Data.Aeson.Lens+import qualified Data.Text as T+import qualified Data.Vector as V+import Network.URI+import Network.HTTP.Link++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'+ → [URI]+discoverEndpoints rels mfRoot linkH = nub $ headerLinks ++ mfLinks+ where headerLinks = map href $ concat $ map (\r → filter (\(Link _ as) → (Rel, r) `elem` as) linkH) rels+ mfLinks = catMaybes $ map parseAesonLink $ concat $ catMaybes $ map (\r → V.toList <$> mfRoot ^? key "rels" . key r . _Array) rels+ parseAesonLink v = (T.unpack <$> v ^? _String) >>= parseURI
+ library/Data/IndieWeb/MicroformatsUtil.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-}++module Data.IndieWeb.MicroformatsUtil where++import Control.Lens+import Data.Maybe+import Data.Aeson+import Data.Aeson.Lens+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HMS+import qualified Data.Text as T++-- | Recursively finds microformats of a given type, also keeping the path (in reverse order) that led to them.+-- Returns Nothing when the given Value isn't an object with an 'items' key, ie. is not a result of Microformats 2 parsing.+allMicroformatsOfType ∷ T.Text → Value → Maybe [(Value, [Value])]+allMicroformatsOfType typeName mf = do+ items ← mf ^? key "items" . _Array+ let findOfType acc path v =+ let valToList (Array vec) = V.toList vec+ valToList _ = []+ childMfs = V.toList $ fromMaybe V.empty $ v ^? key "children" . _Array+ propMfs = concatMap valToList $ HMS.elems $ fromMaybe HMS.empty $ v ^? key "properties" . _Object+ acc' = acc ++ concatMap (findOfType acc $ v : path) (childMfs ++ propMfs) in+ if String typeName `V.elem` fromMaybe V.empty (v ^? key "type" . _Array)+ then (v, path) : acc'+ else acc'+ Just $ concatMap (findOfType [] []) items
+ test-suite/Data/IndieWeb/AuthorshipSpec.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax #-}++module Data.IndieWeb.AuthorshipSpec (spec) where++import Test.Hspec hiding (shouldBe)+import Test.Hspec.Expectations.Pretty (shouldBe)+import TestCommon+import Network.URI+import qualified Data.ByteString.Lazy as LB+import Data.Functor.Identity+import Data.Maybe+import Data.Aeson+import Data.Microformats2.Parser+import Data.IndieWeb.Authorship+import Data.IndieWeb.MicroformatsUtil++spec ∷ Spec+spec = do+ describe "findAuthors" $ do+ let o = object+ mockFetch ∷ URI → Identity (Maybe LB.ByteString)+ mockFetch "http://direct" = return $ Just [xml|<body><div class="h-entry"> <data class=p-name value=Name> <div class="p-author h-card"><h1 class="p-name">Author from Direct!|]+ mockFetch "http://link" = return $ Just [xml|<body><div class="h-entry"> <data class=p-name value=Name> <a class="p-author">http://author/page</a>|]+ mockFetch "http://rel" = return $ Just [xml|<body> <a href="http://author/page" rel="author"></a><div class="h-entry"><data class=p-name value=Name>|]+ mockFetch "http://author/page/link-relative" = return $ Just [xml|<body><div class="h-entry"> <data class=p-name value=Name> <a class="p-author">/page</a>|]+ mockFetch "http://feed" = return $ Just [xml|<body><div class="h-feed"> <div class="p-author h-card"><h1 class="p-name">Author from Feed!</h1></div><div class="h-entry"><data class=p-name value=Name>|]+ mockFetch "http://feed/link" = return $ Just [xml|<body><div class="h-feed"> <a class="p-author">http://author/page</a><div class="h-entry"><data class=p-name value=Name>|]+ mockFetch "http://author/page" = return $ Just [xml|<body><div class="h-card"><h1 class="p-name">Author from Page!|]+ 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 ] ] ]++ it "finds the author h-cards embedded in the h-entry" $ do+ rE "http://direct" `shouldBe` Just [ card "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!" ]++ it "finds the author h-cards linked from the h-entry" $ do+ rE "http://link" `shouldBe` Just [ card' "Author from Page!" ]++ 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!" ]++ 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!" ]
+ test-suite/Data/IndieWeb/EndpointsSpec.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax #-}++module Data.IndieWeb.EndpointsSpec (spec) where++import Test.Hspec hiding (shouldBe)+import Test.Hspec.Expectations.Pretty (shouldBe)+import TestCommon()+import Network.HTTP.Link+import Data.Aeson+import Data.IndieWeb.Endpoints++spec ∷ Spec+spec = do+ describe "discoverEndpoint" $ do+ let dW = discoverEndpoints [ "webmention", "http://webmention.org/" ]+ o = object++ it "finds endpoints in mf2" $ do+ dW (o [ "rels" .= o [ "webmention" .= [ String "http://a/wm1", String "http://a/wm2" ]+ , "http://webmention.org/" .= [ String "http://a/wm3" ]+ , "nope" .= [ String "http://a/nope" ]] ]) [] `shouldBe` [ "http://a/wm1", "http://a/wm2", "http://a/wm3" ]++ it "finds endpoints in the link header" $ do+ dW (o []) [ Link "http://a/wm1" [(Rel, "webmention")]+ , Link "http://a/wm2" [(Rel, "http://webmention.org/")] ] `shouldBe` [ "http://a/wm1", "http://a/wm2" ]++ it "deduplicates links" $ do+ dW (o [ "rels" .= o [ "webmention" .= [ String "http://a/wm3", String "http://a/wm4" ]+ , "http://webmention.org/" .= [ String "http://a/wm2" ]+ , "nope" .= [ String "http://a/nope" ]] ]) [ Link "http://a/wm1" [(Rel, "webmention")]+ , Link "http://a/wm2" [(Rel, "http://webmention.org/")] ] `shouldBe` [ "http://a/wm1", "http://a/wm2", "http://a/wm3", "http://a/wm4" ]
+ test-suite/Data/IndieWeb/MicroformatsUtilSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings, UnicodeSyntax #-}++module Data.IndieWeb.MicroformatsUtilSpec (spec) where++import Test.Hspec hiding (shouldBe)+import Test.Hspec.Expectations.Pretty (shouldBe)+import TestCommon+import Data.Microformats2.Parser+import Data.IndieWeb.MicroformatsUtil++spec ∷ Spec+spec = do+ describe "allMicroformatsOfType" $ do+ it "recursively finds microformats in items" $ do+ let mf = parseMf2 def $ documentRoot $ parseLBS [xml|<body>+ <div class=h-entry>+ <h1 class=p-name>Entry</h1>+ <div class=h-child>+ <data class=p-name value=Child>+ <div class=h-grand-child>Grandchild</div>+ </div>+ <div class="p-prop h-prop-child">+ <data class=p-name value=PropChild>+ <div class=h-grand-child>PropGrandchild</div>+ </div>+ </div>|]+ entryObj = [json|{"type":["h-entry"],"children":[{"value":"Child","type":["h-child"],"children":[{"value":"Grandchild","type":["h-grand-child"],"properties":{"name":["Grandchild"]}}],"properties":{"name":["Child"]}}],"properties":{"name":["Entry"],"prop":[{"value":"PropChild","type":["h-prop-child"],"children":[{"value":"PropGrandchild","type":["h-grand-child"],"properties":{"name":["PropGrandchild"]}}],"properties":{"name":["PropChild"]}}]}}|]+ childObj = [json|{"value":"Child","type":["h-child"],"children":[{"value":"Grandchild","type":["h-grand-child"],"properties":{"name":["Grandchild"]}}],"properties":{"name":["Child"]}}|]+ grandchildObj = [json|{"value":"Grandchild","type":["h-grand-child"],"properties":{"name":["Grandchild"]}}|]+ propchildObj = [json|{"value":"PropChild","type":["h-prop-child"],"children":[{"value":"PropGrandchild","type":["h-grand-child"],"properties":{"name":["PropGrandchild"]}}],"properties":{"name":["PropChild"]}}|]+ propgrandchildObj = [json|{"value":"PropGrandchild","type":["h-grand-child"],"properties":{"name":["PropGrandchild"]}}|]+ allMicroformatsOfType "h-blah" mf `shouldBe` Just []+ allMicroformatsOfType "h-entry" mf `shouldBe` Just [ (entryObj, []) ]+ allMicroformatsOfType "h-child" mf `shouldBe` Just [ (childObj, [entryObj]) ]+ allMicroformatsOfType "h-prop-child" mf `shouldBe` Just [ (propchildObj, [entryObj]) ]+ allMicroformatsOfType "h-grand-child" mf `shouldBe` Just [ (grandchildObj, [childObj, entryObj]), (propgrandchildObj, [propchildObj, entryObj]) ]
+ test-suite/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test-suite/TestCommon.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UnicodeSyntax #-}++module TestCommon (+ xml+, json+, def+, parseURI+, parseURIReference+) where++import Language.Haskell.TH.Quote+import Text.RawString.QQ (r)+import Network.URI (parseURI, parseURIReference, URI)+import Data.Aeson.QQ (aesonQQ)+import Data.Default (def)+import Data.String (IsString, fromString)+import Data.Maybe (fromJust)++instance IsString URI where+ fromString = fromJust . parseURIReference++-- renames for vim+xml, json ∷ QuasiQuoter+xml = r+json = aesonQQ