{-# 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 (Webmention -> Webmention -> Bool
(Webmention -> Webmention -> Bool)
-> (Webmention -> Webmention -> Bool) -> Eq Webmention
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Webmention -> Webmention -> Bool
$c/= :: Webmention -> Webmention -> Bool
== :: Webmention -> Webmention -> Bool
$c== :: Webmention -> Webmention -> Bool
Eq, Int -> Webmention -> ShowS
[Webmention] -> ShowS
Webmention -> String
(Int -> Webmention -> ShowS)
-> (Webmention -> String)
-> ([Webmention] -> ShowS)
-> Show Webmention
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Webmention] -> ShowS
$cshowList :: [Webmention] -> ShowS
show :: Webmention -> String
$cshow :: Webmention -> String
showsPrec :: Int -> Webmention -> ShowS
$cshowsPrec :: Int -> Webmention -> ShowS
Show)

newtype WebmentionError = WebmentionError Text deriving (WebmentionError -> WebmentionError -> Bool
(WebmentionError -> WebmentionError -> Bool)
-> (WebmentionError -> WebmentionError -> Bool)
-> Eq WebmentionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WebmentionError -> WebmentionError -> Bool
$c/= :: WebmentionError -> WebmentionError -> Bool
== :: WebmentionError -> WebmentionError -> Bool
$c== :: WebmentionError -> WebmentionError -> Bool
Eq, Int -> WebmentionError -> ShowS
[WebmentionError] -> ShowS
WebmentionError -> String
(Int -> WebmentionError -> ShowS)
-> (WebmentionError -> String)
-> ([WebmentionError] -> ShowS)
-> Show WebmentionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WebmentionError] -> ShowS
$cshowList :: [WebmentionError] -> ShowS
show :: WebmentionError -> String
$cshow :: WebmentionError -> String
showsPrec :: Int -> WebmentionError -> ShowS
$cshowsPrec :: Int -> WebmentionError -> ShowS
Show)

instance Exception WebmentionError where
  displayException :: WebmentionError -> String
displayException (WebmentionError Text
msg) = Text -> String
T.unpack Text
msg

data WebmentionNotification
  = WebmentionAccepted
  | WebmentionPending StatusURI
  | WebmentionRejected EndpointURI (Response BL.ByteString)
  | WebmentionServerError EndpointURI (Response BL.ByteString)
  | WebmentionNotSupported
  deriving (WebmentionNotification -> WebmentionNotification -> Bool
(WebmentionNotification -> WebmentionNotification -> Bool)
-> (WebmentionNotification -> WebmentionNotification -> Bool)
-> Eq WebmentionNotification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WebmentionNotification -> WebmentionNotification -> Bool
$c/= :: WebmentionNotification -> WebmentionNotification -> Bool
== :: WebmentionNotification -> WebmentionNotification -> Bool
$c== :: WebmentionNotification -> WebmentionNotification -> Bool
Eq, Int -> WebmentionNotification -> ShowS
[WebmentionNotification] -> ShowS
WebmentionNotification -> String
(Int -> WebmentionNotification -> ShowS)
-> (WebmentionNotification -> String)
-> ([WebmentionNotification] -> ShowS)
-> Show WebmentionNotification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WebmentionNotification] -> ShowS
$cshowList :: [WebmentionNotification] -> ShowS
show :: WebmentionNotification -> String
$cshow :: WebmentionNotification -> String
showsPrec :: Int -> WebmentionNotification -> ShowS
$cshowsPrec :: Int -> WebmentionNotification -> ShowS
Show)

data WebmentionVerification
  = SourceMentionsTarget
  | SourceMissingTarget
  | SourceServerError (Response BL.ByteString)
  deriving (WebmentionVerification -> WebmentionVerification -> Bool
(WebmentionVerification -> WebmentionVerification -> Bool)
-> (WebmentionVerification -> WebmentionVerification -> Bool)
-> Eq WebmentionVerification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WebmentionVerification -> WebmentionVerification -> Bool
$c/= :: WebmentionVerification -> WebmentionVerification -> Bool
== :: WebmentionVerification -> WebmentionVerification -> Bool
$c== :: WebmentionVerification -> WebmentionVerification -> Bool
Eq, Int -> WebmentionVerification -> ShowS
[WebmentionVerification] -> ShowS
WebmentionVerification -> String
(Int -> WebmentionVerification -> ShowS)
-> (WebmentionVerification -> String)
-> ([WebmentionVerification] -> ShowS)
-> Show WebmentionVerification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WebmentionVerification] -> ShowS
$cshowList :: [WebmentionVerification] -> ShowS
show :: WebmentionVerification -> String
$cshow :: WebmentionVerification -> String
showsPrec :: Int -> WebmentionVerification -> ShowS
$cshowsPrec :: Int -> WebmentionVerification -> ShowS
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 :: SourceURI -> SourceURI -> m Webmention
webmention SourceURI
source SourceURI
target = do
  SourceURI
s <- SourceURI -> m SourceURI
forall (m :: * -> *). MonadThrow m => SourceURI -> m SourceURI
isHttpUri SourceURI
source
  SourceURI
t <- SourceURI -> m SourceURI
forall (m :: * -> *). MonadThrow m => SourceURI -> m SourceURI
isHttpUri SourceURI
target
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SourceURI
s SourceURI -> SourceURI -> Bool
forall a. Eq a => a -> a -> Bool
== SourceURI
t) (WebmentionError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Text -> WebmentionError
WebmentionError Text
"Source cannot match target."))
  Webmention -> m Webmention
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceURI -> SourceURI -> Webmention
Webmention SourceURI
s SourceURI
t)
  where
    isHttpUri :: MonadThrow m => URI -> m URI
    isHttpUri :: SourceURI -> m SourceURI
isHttpUri SourceURI
uri = do
      let scheme :: Maybe Text
scheme = RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
unRText (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceURI -> Maybe (RText 'Scheme)
uriScheme SourceURI
uri
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\Text
a -> Text
"https" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
a Bool -> Bool -> Bool
&& Text
"http" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
a) Maybe Text
scheme)
        (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ WebmentionError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
        (WebmentionError -> m ()) -> WebmentionError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> WebmentionError
WebmentionError Text
"Only HTTP and HTTPS URIs are allowed."
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either Bool Authority -> Bool
forall a b. Either a b -> Bool
isLeft (SourceURI -> Either Bool Authority
uriAuthority SourceURI
uri) Bool -> Bool -> Bool
|| Maybe (RText 'Scheme) -> Bool
forall a. Maybe a -> Bool
isNothing (SourceURI -> Maybe (RText 'Scheme)
uriScheme SourceURI
uri))
        (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ WebmentionError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
        (WebmentionError -> m ()) -> WebmentionError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> WebmentionError
WebmentionError Text
"URI must be absolute, including HTTP or HTTPS scheme and authority."
      SourceURI -> m SourceURI
forall (m :: * -> *) a. Monad m => a -> m a
return SourceURI
uri

-- | Notify target of 'Webmention'.
notify :: Webmention -> IO WebmentionNotification
notify :: Webmention -> IO WebmentionNotification
notify wm :: Webmention
wm@(Webmention SourceURI
source SourceURI
target) = do
  Maybe SourceURI
endpoint <- Webmention -> IO (Maybe SourceURI)
discoverEndpoint Webmention
wm
  case Maybe SourceURI
endpoint of
    Maybe SourceURI
Nothing -> WebmentionNotification -> IO WebmentionNotification
forall (m :: * -> *) a. Monad m => a -> m a
return WebmentionNotification
WebmentionNotSupported
    Just SourceURI
uri -> do
      let body :: ByteString
body = ByteString -> ByteString
BL.fromStrict (Text -> ByteString
encodeUtf8 (Text
"source=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SourceURI -> Text
render SourceURI
source Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"&target=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SourceURI -> Text
render SourceURI
target))
          length :: ByteString
length = Text -> ByteString
encodeUtf8 (String -> Text
pack (Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length ByteString
body)))
          headers :: [(HeaderName, ByteString)]
headers = [(HeaderName
hContentType, ByteString
"application/x-www-form-urlencoded"), (HeaderName
hContentLength, ByteString
length)]
      Manager
manager <- ManagerSettings -> IO Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newTlsManagerWith (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings
tlsManagerSettings {managerResponseTimeout :: ResponseTimeout
managerResponseTimeout = Int -> ResponseTimeout
responseTimeoutMicro Int
5000000}
      Request
req' <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (Text -> String
unpack (SourceURI -> Text
render SourceURI
uri))
      let req :: Request
req = Request
req' {method :: ByteString
method = ByteString
"POST", requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = [(HeaderName, ByteString)]
headers, requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
body}
      Response ByteString
res <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
manager
      WebmentionNotification -> IO WebmentionNotification
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceURI -> Response ByteString -> WebmentionNotification
wmNotification SourceURI
uri Response ByteString
res)

-- | Verify 'Webmention' source mentions target.
verify :: Webmention -> IO WebmentionVerification
verify :: Webmention -> IO WebmentionVerification
verify wm :: Webmention
wm@(Webmention SourceURI
source SourceURI
target) = do
  Manager
manager <- ManagerSettings -> IO Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newTlsManagerWith (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings
tlsManagerSettings {managerResponseTimeout :: ResponseTimeout
managerResponseTimeout = Int -> ResponseTimeout
responseTimeoutMicro Int
5000000}
  Request
request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (Text -> String
unpack (SourceURI -> Text
render SourceURI
source))
  Response ByteString
res <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
  WebmentionVerification -> IO WebmentionVerification
forall (m :: * -> *) a. Monad m => a -> m a
return (Webmention -> Response ByteString -> WebmentionVerification
wmVerification Webmention
wm Response ByteString
res)

wmVerification :: Webmention -> Response BL.ByteString -> WebmentionVerification
wmVerification :: Webmention -> Response ByteString -> WebmentionVerification
wmVerification (Webmention SourceURI
_ SourceURI
target) Response ByteString
res
  | Status
status Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
>= Status
status200 Bool -> Bool -> Bool
&& Status
status Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
status300 =
    if Text -> ByteString
encodeUtf8 (SourceURI -> Text
render SourceURI
target) ByteString -> ByteString -> Bool
`B.isInfixOf` (ByteString -> ByteString
BL.toStrict (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res))
      then WebmentionVerification
SourceMentionsTarget
      else WebmentionVerification
SourceMissingTarget
  | Status
status Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
>= Status
status400 Bool -> Bool -> Bool
&& Status
status Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
status500 = Response ByteString -> WebmentionVerification
SourceServerError Response ByteString
res
  | Bool
otherwise = Response ByteString -> WebmentionVerification
SourceServerError Response ByteString
res
  where
    status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
res

wmNotification :: URI -> Response BL.ByteString -> WebmentionNotification
wmNotification :: SourceURI -> Response ByteString -> WebmentionNotification
wmNotification SourceURI
uri Response ByteString
res
  | Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status201 = WebmentionNotification
-> (SourceURI -> WebmentionNotification)
-> Maybe SourceURI
-> WebmentionNotification
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WebmentionNotification
WebmentionAccepted SourceURI -> WebmentionNotification
WebmentionPending ([(HeaderName, ByteString)] -> Maybe SourceURI
forall (t :: * -> *).
Foldable t =>
t (HeaderName, ByteString) -> Maybe SourceURI
parseLocationUrl (Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
res))
  | Status
status Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
>= Status
status200 Bool -> Bool -> Bool
&& Status
status Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
status300 = WebmentionNotification
WebmentionAccepted
  | Status
status Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
>= Status
status400 Bool -> Bool -> Bool
&& Status
status Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
status500 = SourceURI -> Response ByteString -> WebmentionNotification
WebmentionRejected SourceURI
uri Response ByteString
res
  | Bool
otherwise = SourceURI -> Response ByteString -> WebmentionNotification
WebmentionServerError SourceURI
uri Response ByteString
res
  where
    parseLocationUrl :: t (HeaderName, ByteString) -> Maybe SourceURI
parseLocationUrl t (HeaderName, ByteString)
hs = Text -> Maybe SourceURI
forall (m :: * -> *). MonadThrow m => Text -> m SourceURI
mkURI (Text -> Maybe SourceURI)
-> (ByteString -> Text) -> ByteString -> Maybe SourceURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Maybe SourceURI)
-> Maybe ByteString -> Maybe SourceURI
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((HeaderName, ByteString) -> ByteString)
-> Maybe (HeaderName, ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((HeaderName, ByteString) -> Bool)
-> t (HeaderName, ByteString) -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hLocation) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) t (HeaderName, ByteString)
hs)
    status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
res

discoverEndpoint :: Webmention -> IO (Maybe URI)
discoverEndpoint :: Webmention -> IO (Maybe SourceURI)
discoverEndpoint (Webmention SourceURI
source SourceURI
target) = do
  Manager
manager <- ManagerSettings -> IO Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newTlsManagerWith (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings
tlsManagerSettings {managerResponseTimeout :: ResponseTimeout
managerResponseTimeout = Int -> ResponseTimeout
responseTimeoutMicro Int
5000000}
  Request
request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (Text -> String
unpack (SourceURI -> Text
render SourceURI
target))
  (Webmention
wm, Response ByteString
res) <- Request
-> Manager
-> (HistoriedResponse BodyReader
    -> IO (Webmention, Response ByteString))
-> IO (Webmention, Response ByteString)
forall a.
Request
-> Manager -> (HistoriedResponse BodyReader -> IO a) -> IO a
withResponseHistory Request
request Manager
manager ((HistoriedResponse BodyReader
  -> IO (Webmention, Response ByteString))
 -> IO (Webmention, Response ByteString))
-> (HistoriedResponse BodyReader
    -> IO (Webmention, Response ByteString))
-> IO (Webmention, Response ByteString)
forall a b. (a -> b) -> a -> b
$ \HistoriedResponse BodyReader
hr -> do
    let req :: Request
req = HistoriedResponse BodyReader -> Request
forall body. HistoriedResponse body -> Request
hrFinalRequest HistoriedResponse BodyReader
hr
        protocol :: ByteString
protocol = if Request -> Bool
secure Request
req then ByteString
"https://" else ByteString
"http://"
        finalRes :: Response BodyReader
finalRes = HistoriedResponse BodyReader -> Response BodyReader
forall body. HistoriedResponse body -> Response body
hrFinalResponse HistoriedResponse BodyReader
hr
        finalUri :: SourceURI
finalUri = Maybe SourceURI -> SourceURI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe SourceURI -> SourceURI)
-> (ByteString -> Maybe SourceURI) -> ByteString -> SourceURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe SourceURI
forall (m :: * -> *). MonadThrow m => Text -> m SourceURI
mkURI (Text -> Maybe SourceURI)
-> (ByteString -> Text) -> ByteString -> Maybe SourceURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> SourceURI) -> ByteString -> SourceURI
forall a b. (a -> b) -> a -> b
$ ByteString
protocol ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
host Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
path Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
queryString Request
req
        redirectedWm :: Webmention
redirectedWm = SourceURI -> SourceURI -> Webmention
Webmention SourceURI
source SourceURI
finalUri -- to resolve endpoint against redirected URI
    ByteString
body <- [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BodyReader -> IO [ByteString]
brConsume (Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
finalRes)
    (Webmention, Response ByteString)
-> IO (Webmention, Response ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Webmention
redirectedWm, Response BodyReader
finalRes {responseBody :: ByteString
responseBody = ByteString
body})
  Maybe SourceURI -> IO (Maybe SourceURI)
forall (m :: * -> *) a. Monad m => a -> m a
return (Webmention -> Response ByteString -> Maybe SourceURI
discoverEndpointFromHeader Webmention
wm Response ByteString
res Maybe SourceURI -> Maybe SourceURI -> Maybe SourceURI
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Webmention -> Response ByteString -> Maybe SourceURI
discoverEndpointFromHtml Webmention
wm Response ByteString
res)

discoverEndpointFromHeader :: Webmention -> Response BL.ByteString -> Maybe URI
discoverEndpointFromHeader :: Webmention -> Response ByteString -> Maybe SourceURI
discoverEndpointFromHeader (Webmention SourceURI
_ SourceURI
target) Response ByteString
res = [(HeaderName, ByteString)] -> Maybe SourceURI
forall s.
(Eq s, FoldCase s, IsString s) =>
[(CI s, ByteString)] -> Maybe SourceURI
go (Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
res)
  where
    go :: [(CI s, ByteString)] -> Maybe SourceURI
go [] = Maybe SourceURI
forall a. Maybe a
Nothing
    go ((CI s, ByteString)
h : [(CI s, ByteString)]
hs) = (CI s, ByteString) -> Maybe SourceURI
forall s.
(Eq s, FoldCase s, IsString s) =>
(CI s, ByteString) -> Maybe SourceURI
matchWmHeader (CI s, ByteString)
h Maybe SourceURI -> Maybe SourceURI -> Maybe SourceURI
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(CI s, ByteString)] -> Maybe SourceURI
go [(CI s, ByteString)]
hs
    headerVal :: Text -> Text
headerVal Text
txt = Int -> Text -> Text
T.drop Int
1 (Int -> Text -> Text
T.dropEnd Int
1 ([Text] -> Text
forall a. [a] -> a
L.head (Text -> Text
strip (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') Text
txt)))
    headerParams :: Text -> [Text]
headerParams Text
txt = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
L.drop Int
1 (Text -> Text
strip (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') Text
txt)
    headerVals :: (a, ByteString) -> [Text]
headerVals (a
_, ByteString
bs) = Text -> Text
strip (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Text -> [Text]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') (ByteString -> Text
decodeUtf8 ByteString
bs)
    isWmRel :: Text -> Bool
isWmRel Text
txt = Int -> Text -> Text
T.take Int
4 Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"rel=" Bool -> Bool -> Bool
&& Text
"webmention" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` Text -> Text -> [Text]
T.splitOn Text
" " (Text -> Text
unquote (Int -> Text -> Text
T.drop Int
4 Text
txt))
    hasWmRel :: Text -> Bool
hasWmRel Text
val = Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust ((Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find Text -> Bool
isWmRel (Text -> [Text]
headerParams Text
val))
    isWmLink :: (CI s, b) -> Bool
isWmLink (CI s
k, b
_) = CI s
k CI s -> CI s -> Bool
forall a. Eq a => a -> a -> Bool
== s -> CI s
forall s. FoldCase s => s -> CI s
mk s
"Link"
    headerUri :: Text -> Maybe SourceURI
headerUri Text
val = (SourceURI -> SourceURI -> Maybe SourceURI)
-> SourceURI -> SourceURI -> Maybe SourceURI
forall a b c. (a -> b -> c) -> b -> a -> c
flip SourceURI -> SourceURI -> Maybe SourceURI
relativeTo SourceURI
target (SourceURI -> Maybe SourceURI)
-> Maybe SourceURI -> Maybe SourceURI
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe SourceURI
forall (m :: * -> *). MonadThrow m => Text -> m SourceURI
mkURI Text
val
    matchWmHeader :: (CI s, ByteString) -> Maybe SourceURI
matchWmHeader (CI s, ByteString)
h =
      if (CI s, ByteString) -> Bool
forall s b. (Eq s, FoldCase s, IsString s) => (CI s, b) -> Bool
isWmLink (CI s, ByteString)
h
        then Text -> Maybe SourceURI
headerUri (Text -> Maybe SourceURI) -> Maybe Text -> Maybe SourceURI
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Text -> Text
headerVal (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find Text -> Bool
hasWmRel ((CI s, ByteString) -> [Text]
forall a. (a, ByteString) -> [Text]
headerVals (CI s, ByteString)
h))
        else Maybe SourceURI
forall a. Maybe a
Nothing
    unquote :: Text -> Text
unquote Text
txt = if Int -> Text -> Text
T.take Int
1 Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"\"" then Int -> Text -> Text
T.drop Int
1 (Int -> Text -> Text
T.dropEnd Int
1 Text
txt) else Text
txt

discoverEndpointFromHtml :: Webmention -> Response BL.ByteString -> Maybe URI
discoverEndpointFromHtml :: Webmention -> Response ByteString -> Maybe SourceURI
discoverEndpointFromHtml (Webmention SourceURI
_ SourceURI
target) Response ByteString
res =
  if [(HeaderName, ByteString)] -> Bool
forall (t :: * -> *).
Foldable t =>
t (HeaderName, ByteString) -> Bool
isHtml (Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
res) then [Tag ByteString] -> Maybe SourceURI
go (ByteString -> [Tag ByteString]
forall str. StringLike str => str -> [Tag str]
parseTags (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res)) else Maybe SourceURI
forall a. Maybe a
Nothing
  where
    go :: [Tag ByteString] -> Maybe SourceURI
go (t :: Tag ByteString
t@(TagOpen ByteString
"link" [Attribute ByteString]
_) : [Tag ByteString]
ts) = if Tag ByteString -> Bool
isRelWm Tag ByteString
t then Tag ByteString -> Maybe SourceURI
hrefUri Tag ByteString
t Maybe SourceURI -> Maybe SourceURI -> Maybe SourceURI
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Tag ByteString] -> Maybe SourceURI
go [Tag ByteString]
ts else [Tag ByteString] -> Maybe SourceURI
go [Tag ByteString]
ts
    go (t :: Tag ByteString
t@(TagOpen ByteString
"a" [Attribute ByteString]
_) : [Tag ByteString]
ts) = if Tag ByteString -> Bool
isRelWm Tag ByteString
t then Tag ByteString -> Maybe SourceURI
hrefUri Tag ByteString
t Maybe SourceURI -> Maybe SourceURI -> Maybe SourceURI
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Tag ByteString] -> Maybe SourceURI
go [Tag ByteString]
ts else [Tag ByteString] -> Maybe SourceURI
go [Tag ByteString]
ts
    go (Tag ByteString
t : [Tag ByteString]
ts) = [Tag ByteString] -> Maybe SourceURI
go [Tag ByteString]
ts
    go [] = Maybe SourceURI
forall a. Maybe a
Nothing
    isHtml :: t (HeaderName, ByteString) -> Bool
isHtml t (HeaderName, ByteString)
hs = Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ByteString -> ByteString -> Bool
B.isInfixOf ByteString
"html") ((HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((HeaderName, ByteString) -> ByteString)
-> Maybe (HeaderName, ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((HeaderName, ByteString) -> Bool)
-> t (HeaderName, ByteString) -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hContentType) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) t (HeaderName, ByteString)
hs)
    hrefUri :: Tag ByteString -> Maybe SourceURI
hrefUri Tag ByteString
t = ByteString -> Maybe SourceURI
resolve (ByteString -> Maybe SourceURI)
-> Maybe ByteString -> Maybe SourceURI
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tag ByteString -> Maybe ByteString
forall b. (Eq b, IsString b) => Tag b -> Maybe b
href Tag ByteString
t
    href :: Tag b -> Maybe b
href (TagOpen b
_ [Attribute b]
attrs) = Attribute b -> b
forall a b. (a, b) -> b
snd (Attribute b -> b) -> Maybe (Attribute b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Attribute b -> Bool) -> [Attribute b] -> Maybe (Attribute b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
"href") (b -> Bool) -> (Attribute b -> b) -> Attribute b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute b -> b
forall a b. (a, b) -> a
fst) [Attribute b]
attrs
    resolve :: ByteString -> Maybe SourceURI
resolve ByteString
"" = SourceURI -> Maybe SourceURI
forall a. a -> Maybe a
Just SourceURI
target -- empty href should resolve to same page
    resolve ByteString
bs = (SourceURI -> SourceURI -> Maybe SourceURI)
-> SourceURI -> SourceURI -> Maybe SourceURI
forall a b c. (a -> b -> c) -> b -> a -> c
flip SourceURI -> SourceURI -> Maybe SourceURI
relativeTo SourceURI
target (SourceURI -> Maybe SourceURI)
-> Maybe SourceURI -> Maybe SourceURI
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe SourceURI
forall (m :: * -> *). MonadThrow m => Text -> m SourceURI
mkURI (ByteString -> Text
decodeUtf8 (ByteString -> ByteString
BL.toStrict ByteString
bs))
    isRelWm :: Tag ByteString -> Bool
isRelWm Tag ByteString
t = Text
"webmention" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` Text -> Text -> [Text]
T.splitOn Text
" " (ByteString -> Text
decodeUtf8 (ByteString -> ByteString
BL.toStrict (ByteString -> Tag ByteString -> ByteString
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib ByteString
"rel" Tag ByteString
t)))