webmention (empty) → 0.1.0.0
raw patch · 7 files changed
+440/−0 lines, 7 filesdep +basedep +bytestringdep +case-insensitivesetup-changed
Dependencies added: base, bytestring, case-insensitive, either, exceptions, hspec, http-client, http-client-tls, http-types, modern-uri, tagsoup, text, webmention
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +9/−0
- Setup.hs +2/−0
- src/Network/HTTP/Webmention.hs +179/−0
- test/Spec.hs +141/−0
- webmention.cabal +74/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for webmention++## v0.1.0.0++- Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alexander Mingoia (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,9 @@+# webmention++Types and functions for working with+[Webmention](https://www.w3.org/TR/webmention), which pass the+[webmention.rocks](https://webmention.rocks/) test suite.++- `webmention` function constructs a valid `Webmention` type.+- `notify` function sends a `Webmention`, handling endpoint discovery.+- `verify` function verifies a `Webmention` source mentions its target.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Network/HTTP/Webmention.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Webmention+ ( webmention,+ notify,+ verify,+ Webmention,+ WebmentionNotification (..),+ WebmentionVerification (..),+ WebmentionError,+ SourceURI,+ TargetURI,+ EndpointURI,+ StatusURI,+ )+where++import Control.Applicative+import Control.Exception+import Control.Monad+import Control.Monad.Catch+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.CaseInsensitive+import Data.Char+import Data.Either.Combinators+import Data.List as L+import Data.Maybe+import Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Network.HTTP.Client+import Network.HTTP.Client.TLS+import Network.HTTP.Types+import Network.HTTP.Types.Header+import Text.HTML.TagSoup+import Text.URI++type EndpointURI = URI++type StatusURI = URI++type SourceURI = URI++type TargetURI = URI++data Webmention = Webmention SourceURI TargetURI deriving (Eq, Show)++newtype WebmentionError = WebmentionError Text deriving (Eq, Show)++instance Exception WebmentionError where+ displayException (WebmentionError msg) = T.unpack msg++data WebmentionNotification+ = WebmentionAccepted+ | WebmentionPending StatusURI+ | WebmentionRejected EndpointURI (Response BL.ByteString)+ | WebmentionServerError EndpointURI (Response BL.ByteString)+ | WebmentionNotSupported+ deriving (Eq, Show)++data WebmentionVerification+ = SourceMentionsTarget+ | SourceMissingTarget+ | SourceServerError (Response BL.ByteString)+ deriving (Eq, Show)++-- | Construct a valid 'Webmention' from source and target 'URI'.+--+-- Throws a 'WebmentionError' if source and target are the same, are+-- relative, or lack an HTTP(S) scheme.+webmention :: MonadThrow m => SourceURI -> TargetURI -> m Webmention+webmention source target = do+ s <- isHttpUri source+ t <- isHttpUri target+ when (s == t) (throwM (WebmentionError "Source cannot match target."))+ return (Webmention s t)+ where+ isHttpUri :: MonadThrow m => URI -> m URI+ isHttpUri uri = do+ let scheme = unRText <$> uriScheme uri+ when (maybe False (\a -> "https" /= a && "http" /= a) scheme)+ $ throwM+ $ WebmentionError "Only HTTP and HTTPS URIs are allowed."+ when (isLeft (uriAuthority uri) || isNothing (uriScheme uri))+ $ throwM+ $ WebmentionError "URI must be absolute, including HTTP or HTTPS scheme and authority."+ return uri++-- | Notify target of 'Webmention'.+notify :: Webmention -> IO WebmentionNotification+notify wm@(Webmention source target) = do+ endpoint <- discoverEndpoint wm+ case endpoint of+ Nothing -> return WebmentionNotSupported+ Just uri -> do+ let body = BL.fromStrict (encodeUtf8 ("source=" <> render source <> "&target=" <> render target))+ length = encodeUtf8 (pack (show (BL.length body)))+ headers = [(hContentType, "application/x-www-form-urlencoded"), (hContentLength, length)]+ manager <- newTlsManagerWith $ tlsManagerSettings {managerResponseTimeout = responseTimeoutMicro 5000000}+ req' <- parseRequest (unpack (render uri))+ let req = req' {method = "POST", requestHeaders = headers, requestBody = RequestBodyLBS body}+ res <- httpLbs req manager+ return (wmNotification uri res)++-- | Verify 'Webmention' source mentions target.+verify :: Webmention -> IO WebmentionVerification+verify wm@(Webmention source target) = do+ manager <- newTlsManagerWith $ tlsManagerSettings {managerResponseTimeout = responseTimeoutMicro 5000000}+ request <- parseRequest (unpack (render source))+ res <- httpLbs request manager+ return (wmVerification wm res)++wmVerification :: Webmention -> Response BL.ByteString -> WebmentionVerification+wmVerification (Webmention _ target) res+ | status >= status200 && status < status300 =+ if encodeUtf8 (render target) `B.isInfixOf` (BL.toStrict (responseBody res))+ then SourceMentionsTarget+ else SourceMissingTarget+ | status >= status400 && status < status500 = SourceServerError res+ | otherwise = SourceServerError res+ where+ status = responseStatus res++wmNotification :: URI -> Response BL.ByteString -> WebmentionNotification+wmNotification uri res+ | status == status201 = maybe WebmentionAccepted WebmentionPending (parseLocationUrl (responseHeaders res))+ | status >= status200 && status < status300 = WebmentionAccepted+ | status >= status400 && status < status500 = WebmentionRejected uri res+ | otherwise = WebmentionServerError uri res+ where+ parseLocationUrl hs = mkURI . decodeUtf8 =<< (snd <$> L.find ((== hLocation) . fst) hs)+ status = responseStatus res++discoverEndpoint :: Webmention -> IO (Maybe URI)+discoverEndpoint (Webmention source target) = do+ manager <- newTlsManagerWith $ tlsManagerSettings {managerResponseTimeout = responseTimeoutMicro 5000000}+ request <- parseRequest (unpack (render target))+ (wm, res) <- withResponseHistory request manager $ \hr -> do+ let req = hrFinalRequest hr+ protocol = if secure req then "https://" else "http://"+ finalRes = hrFinalResponse hr+ finalUri = fromJust . mkURI . decodeUtf8 $ protocol <> host req <> path req <> queryString req+ redirectedWm = Webmention source finalUri -- to resolve endpoint against redirected URI+ body <- BL.fromChunks <$> brConsume (responseBody finalRes)+ return (redirectedWm, finalRes {responseBody = body})+ return (discoverEndpointFromHeader wm res <|> discoverEndpointFromHtml wm res)++discoverEndpointFromHeader :: Webmention -> Response BL.ByteString -> Maybe URI+discoverEndpointFromHeader (Webmention _ target) res = go (responseHeaders res)+ where+ go [] = Nothing+ go (h : hs) = matchWmHeader h <|> go hs+ headerVal txt = T.drop 1 (T.dropEnd 1 (L.head (strip <$> T.split (== ';') txt)))+ headerParams txt = L.drop 1 (strip <$> T.split (== ';') txt)+ headerVals (_, bs) = strip <$> split (== ',') (decodeUtf8 bs)+ isWmRel txt = T.take 4 txt == "rel=" && "webmention" `L.elem` T.splitOn " " (unquote (T.drop 4 txt))+ hasWmRel val = isJust (L.find isWmRel (headerParams val))+ isWmLink (k, _) = k == mk "Link"+ headerUri val = flip relativeTo target =<< mkURI val+ matchWmHeader h =+ if isWmLink h+ then headerUri =<< (headerVal <$> L.find hasWmRel (headerVals h))+ else Nothing+ unquote txt = if T.take 1 txt == "\"" then T.drop 1 (T.dropEnd 1 txt) else txt++discoverEndpointFromHtml :: Webmention -> Response BL.ByteString -> Maybe URI+discoverEndpointFromHtml (Webmention _ target) res =+ if isHtml (responseHeaders res) then go (parseTags (responseBody res)) else Nothing+ where+ go (t@(TagOpen "link" _) : ts) = if isRelWm t then hrefUri t <|> go ts else go ts+ go (t@(TagOpen "a" _) : ts) = if isRelWm t then hrefUri t <|> go ts else go ts+ go (t : ts) = go ts+ go [] = Nothing+ isHtml hs = maybe False (B.isInfixOf "html") (snd <$> L.find ((== hContentType) . fst) hs)+ hrefUri t = resolve =<< href t+ href (TagOpen _ attrs) = snd <$> L.find ((== "href") . fst) attrs+ resolve "" = Just target -- empty href should resolve to same page+ resolve bs = flip relativeTo target =<< mkURI (decodeUtf8 (BL.toStrict bs))+ isRelWm t = "webmention" `L.elem` T.splitOn " " (decodeUtf8 (BL.toStrict (fromAttrib "rel" t)))
+ test/Spec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.Maybe+import Data.Text+import Network.HTTP.Webmention+import Test.Hspec+import Text.URI++main :: IO ()+main = hspec $ do+ describe "Network.HTTP.Webmention" $ do+ it "HTTP Link header, unquoted rel, relative URL" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/1"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/1/webmention"+ it "HTTP Link header, unquoted rel, absolute URL" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/2"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/2/webmention"+ it "HTML <link> tag, relative URL" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/3"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/3/webmention"+ it "HTML <link> tag, absolute URL" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/4"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/4/webmention"+ it "HTML <a> tag, relative URL" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/5"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/5/webmention"+ it "HTML <a> tag, absolute URL" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/6"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/6/webmention"+ it "HTTP Link header with strange casing" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/8"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/8/webmention"+ it "HTTP Link header, quoted rel" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/8"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/8/webmention"+ it "Multiple rel values on a <link> tag" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/9"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/9/webmention"+ it "Multiple rel values on Link header" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/10"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/10/webmention"+ it "Multiple Webmention endpoints advertised: Link, <link>, <a>" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/11"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/11/webmention"+ it "Checking for exact match of rel=webmention" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/12"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/12/webmention"+ it "False endpoint inside an HTML comment" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/13"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/13/webmention"+ it "False endpoint in escaped HTML" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/14"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/14/webmention"+ it "Webmention href is an empty string" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/15"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/15"+ it "Multiple Webmention endpoints advertised: <a>, <link>" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/16"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/16/webmention"+ it "Multiple Webmention endpoints advertised: <link>, <a>" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/17"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/17/webmention"+ it "Multiple HTTP Link headers" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/18"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/18/webmention"+ it "Single HTTP Link header with multiple values" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/19"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/19/webmention"+ it "Link tag with no href attribute" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/20"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/20/webmention"+ it "Webmention endpoint has query string parameters" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/21"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/21/webmention?query=yes"+ it "Webmention endpoint is relative to the path" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/22"+ n <- notify =<< webmention source target+ endpoint n `shouldBe` Just "https://webmention.rocks/test/22/webmention"+ it "Webmention target is a redirect and the endpoint is relative" $ do+ source <- mkURI "https://webmention.rocks/"+ target <- mkURI "https://webmention.rocks/test/23/page"+ n <- notify =<< webmention source target+ endpoint n `shouldSatisfy` (maybe False (isPrefixOf "https://webmention.rocks/test/23/page/webmention-endpoint"))+ it "verifies webmention source mentions target" $ do+ source <- mkURI "https://webmention.rocks/test/6"+ target <- mkURI "https://webmention.rocks/test/6/webmention"+ v <- verify =<< webmention source target+ v `shouldBe` SourceMentionsTarget+ it "verifies webmention source does not mention target" $ do+ source <- mkURI "https://webmention.rocks/test/6"+ target <- mkURI "https://webmention.rocks/test/7"+ v <- verify =<< webmention source target+ v `shouldBe` SourceMissingTarget++endpoint :: WebmentionNotification -> Maybe Text+endpoint (WebmentionRejected endpoint _) = Just (render endpoint)+endpoint (WebmentionServerError endpoint _) = Just (render endpoint)+endpoint _ = Nothing
+ webmention.cabal view
@@ -0,0 +1,74 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 22b1aa45d8fecebd6c0929552a97b240054679c41de2362a8c92b06f1d547612++name: webmention+version: 0.1.0.0+synopsis: Types and functions for working with Webmentions.+description: Types and functions for working with [Webmention](https://www.w3.org/TR/webmention), which pass the [webmention.rocks](https://webmention.rocks/) test suite.+category: Web+homepage: https://github.com/alexmingoia/webmention#readme+bug-reports: https://github.com/alexmingoia/webmention/issues+author: Alexander Mingoia+maintainer: alex@alexmingoia.com+copyright: 2020 Alexander Mingoia+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/alexmingoia/webmention++library+ exposed-modules:+ Network.HTTP.Webmention+ other-modules:+ Paths_webmention+ hs-source-dirs:+ src+ build-depends:+ base >=4 && <5+ , bytestring >=0.10 && <0.11+ , case-insensitive >=1.2 && <1.3+ , either >=5.0 && <5.1+ , exceptions >=0.10 && <0.11+ , hspec >=2.7 && <2.8+ , http-client >=0.6 && <0.7+ , http-client-tls >=0.3 && <0.4+ , http-types >=0.12 && <0.13+ , modern-uri >=0.3 && <0.4+ , tagsoup >=0.14 && <0.15+ , text >=1.2 && <1.3+ default-language: Haskell2010++test-suite webmention-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_webmention+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4 && <5+ , bytestring >=0.10 && <0.11+ , case-insensitive >=1.2 && <1.3+ , either >=5.0 && <5.1+ , exceptions >=0.10 && <0.11+ , hspec >=2.7 && <2.8+ , http-client >=0.6 && <0.7+ , http-client-tls >=0.3 && <0.4+ , http-types >=0.12 && <0.13+ , modern-uri >=0.3 && <0.4+ , tagsoup >=0.14 && <0.15+ , text >=1.2 && <1.3+ , webmention+ default-language: Haskell2010