{- This file is part of webfinger-client.
 -
 - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- For Text and ByteString literals
{-# LANGUAGE OverloadedStrings #-}

-- For generating Hashable instance
{-# LANGUAGE DeriveGeneric #-}

-- To allow Language-hashed maps be FromJSON
{-# LANGUAGE FlexibleInstances #-}

-- For avoiding redundant imports in base 4.8
{-# LANGUAGE CPP #-}

-- | A Haskell client library for performing WebFinger queries.
--
-- This module provides functions and data types for constructing and sending
-- WebFinger queries over HTTPS. It allows users to query information about
-- various resources, such as accounts or URIs, and retrieve associated metadata
-- as described in the WebFinger protocol.
--
-- The main entry points are:
--
-- * 'webfinger' – Sends a WebFinger query and returns a structured response.
-- * 'newManager' – Creates an HTTPS connection manager required for making requests.
--
-- The core data types include:
--
-- * 'Query' – Represents a WebFinger query.
-- * 'Resource' – Specifies the entity being queried.
-- * 'Description' – Contains the response data from a WebFinger query.
-- * 'Link' – Represents links returned in a WebFinger response.
-- * 'Language' – Defines language codes used in WebFinger responses.
--
-- This module depends on 'http-client' and 'aeson' for handling HTTP requests
-- and JSON parsing.
module Web.Finger.Client
    ( Account (..)
    , Resource (..)
    , Auth (..)
    , Query (..)
    , Link (..)
    , Description (..)
    , Result (..)
    , newManager
    , webfinger
    , Language
    )
where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif

import Control.Exception
import Data.Aeson hiding (Result, Success)
import Data.Aeson.Types (typeMismatch)
import Data.ByteString (ByteString)
import Data.Default.Class
import Data.Hashable
import Data.HashMap.Lazy (HashMap)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import GHC.Generics (Generic)
import Web.LinkRelations (LinkRelation, fromByteString, toByteString)

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.HashMap.Lazy as M
import qualified Network.HTTP.Client as H
import qualified Network.HTTP.Client.TLS as H
import qualified Network.HTTP.Types as HT
import qualified URI.ByteString as U

{- URI ideas

* [/] allow to pass a URI string or a URI as per Network.URI, does http-client not depend on it anyway?
* [x]                  - // -                    URI.ByteString
* [x] allow to pass user and host and treat as an acct URI
* [/] if URI has no scheme and a single @, assume it is user@host and treat as acct
* [x] if URI has no ':' but does have '@', treat as an acct URI
* [x] in Go it takes absolute URL or email - should I require that a URI passed be
  absolute? what does it mean not to be absolute? DONE assume it's absolute
* [x] make acct URIs get parsed, i.e. hostname extracted correctly

 - Other Nodes

* [x] Support typed link relations
* [ ] Support typed properties
* [x] Add an HTTP Accept header containing the JRD MIME type, the python module
  does it. But first read in the RFC to make sure it's ok
-}

-- | A given user at a given host. For example, /john@example.org/ means the
-- user is /john/ and the host is /example.org/.
data Account = Account
    { Account -> ByteString
acctUser :: ByteString
    , Account -> ByteString
acctHost :: ByteString
    }

-- | A web resource about which you'd like to make a query.
data Resource
    = ResAccount Account
    | ResUri U.URI
    | ResUriStr ByteString

-- | HTTP user authentication details.
data Auth = Auth
    { Auth -> ByteString
authUser     :: ByteString
    , Auth -> ByteString
authPassword :: ByteString
    }

-- | A WebFinger query, for which the client can get a response.
--
-- In the 'Default' instance, all fields are empty/null and there are no
-- auth details. Therefore you must at least (but it is also enough to) specify
-- the 'qryTarget' URI.
data Query = Query
    { -- | A URI representing an entity about which you would like to get
      -- information.
      Query -> Resource
qryTarget   :: Resource
      -- | A list of link relations by which to filter the link list in the
      -- returned description. If you'd like to receive /all/ the links, leave
      -- this list empty. Use 'Left' to specify a raw link relation string, and
      -- 'Right' to specify a known typed relation.
    , Query -> [Either ByteString LinkRelation]
qryLinkRels :: [Either ByteString LinkRelation]
      -- | You can explicitly specify a host (e.g. @www.example.org@) here, to
      -- which the WebFinger query will be sent. If you don't specify a host
      -- here, it will be extracted from the 'qryTarget' field (if it has a
      -- host part). Therefore this field is useful in special cases where the
      -- WebFinger server isn't the one referred by the target URI, or the URI
      -- doesn't have a host.
    , Query -> Maybe ByteString
qryHost     :: Maybe ByteString
      -- | HTTP authentication details. If the WebFinger server requires a
      -- username and password to access it, specify them here. For publicly
      -- available WebFinger servers, pass 'Nothing'.
    , Query -> Maybe Auth
qryAuth     :: Maybe Auth
    }

instance Default Query where
    def :: Query
def = Query
        { qryTarget :: Resource
qryTarget   = ByteString -> Resource
ResUriStr ByteString
B.empty
        , qryLinkRels :: [Either ByteString LinkRelation]
qryLinkRels = []
        , qryHost :: Maybe ByteString
qryHost     = Maybe ByteString
forall a. Maybe a
Nothing
        , qryAuth :: Maybe Auth
qryAuth     = Maybe Auth
forall a. Maybe a
Nothing
        }

-- | Natural Language code. Used to express in which language a text string is
-- written.
data Language
    -- | A specific language specified using a code, e.g. @en-us@.
    = LanguageCode Text
    -- | No specific language. However it doesn't mean that nothing is
    -- specified. It means that "language undefined" is explicity specified.
    | LanguageUndefined
    deriving (Language -> Language -> Bool
(Language -> Language -> Bool)
-> (Language -> Language -> Bool) -> Eq Language
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Language -> Language -> Bool
== :: Language -> Language -> Bool
$c/= :: Language -> Language -> Bool
/= :: Language -> Language -> Bool
Eq, (forall x. Language -> Rep Language x)
-> (forall x. Rep Language x -> Language) -> Generic Language
forall x. Rep Language x -> Language
forall x. Language -> Rep Language x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Language -> Rep Language x
from :: forall x. Language -> Rep Language x
$cto :: forall x. Rep Language x -> Language
to :: forall x. Rep Language x -> Language
Generic, Int -> Language -> ShowS
[Language] -> ShowS
Language -> String
(Int -> Language -> ShowS)
-> (Language -> String) -> ([Language] -> ShowS) -> Show Language
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Language -> ShowS
showsPrec :: Int -> Language -> ShowS
$cshow :: Language -> String
show :: Language -> String
$cshowList :: [Language] -> ShowS
showList :: [Language] -> ShowS
Show)

instance Hashable Language

instance FromJSON Language where
    parseJSON :: Value -> Parser Language
parseJSON (String Text
t) = Language -> Parser Language
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Language
toLang Text
t)
    parseJSON Value
v = String -> Value -> Parser Language
forall a. String -> Value -> Parser a
typeMismatch String
"Language" Value
v

instance FromJSONKey Language where
    fromJSONKey :: FromJSONKeyFunction Language
fromJSONKey = (Text -> Language) -> FromJSONKeyFunction Language
forall a. (Text -> a) -> FromJSONKeyFunction a
FromJSONKeyText Text -> Language
toLang

toLang :: Text -> Language
toLang :: Text -> Language
toLang Text
t =
    if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"und"
        then Language
LanguageUndefined
        else Text -> Language
LanguageCode Text
t

-- | Represents a link from the target resource to some other web resource.
-- This is more than a simple webpage link: It also has a relation type (i.e.
-- what is the relation between the target resource and the referred resource)
-- and additional properties.
data Link = Link
    { -- | The link relation type. Determines the relation between the target
      -- resource (about which the query was made) and the resource referred by
      -- the link. For example, if the target resource is a user and the linked
      -- resource is the user's avatar image, the link relation may be
      -- /avatar/.
      --
      -- A link relation may be a URI or one of the registered relation type
      -- names. If the relation type is recognized when parsing the server's
      -- response, you will get 'Right' a typed link relation here. Otherwise,
      -- e.g. if a non-URL private application-specific relation type is found,
      -- you will get 'Left' the raw relation type string.
      Link -> Either Text LinkRelation
lnkRelation   :: Either Text LinkRelation
      -- | The MIME type to be expected of the content behind the link URI. For
      -- example, if the link refers to a user's avatar image, the MIME type
      -- may be @image/png@ (i.e. an image file in PNG format).
    , Link -> Maybe Text
lnkMediaType  :: Maybe Text
      -- | The link address itself. It is optional, because there may be cases
      -- in which all the information about the link is provided by the
      -- properties (the 'lnkProperties' field). For example, if the link is a
      -- user's avatar image, the address may be
      -- @https://example.org/users/john/avatar.png@.
    , Link -> Maybe Text
lnkAddress    :: Maybe Text
      -- | Optional title(s) for the link, possibly in various languages.
    , Link -> HashMap Language Text
lnkTitles     :: HashMap Language Text
      -- | Additional properties the link may have. Maps property names, which
      -- are URIs, to string values.
    , Link -> HashMap Text (Maybe Text)
lnkProperties :: HashMap Text (Maybe Text) --TODO use IANA database to parse known values?
    }
    deriving (Int -> Link -> ShowS
[Link] -> ShowS
Link -> String
(Int -> Link -> ShowS)
-> (Link -> String) -> ([Link] -> ShowS) -> Show Link
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Link -> ShowS
showsPrec :: Int -> Link -> ShowS
$cshow :: Link -> String
show :: Link -> String
$cshowList :: [Link] -> ShowS
showList :: [Link] -> ShowS
Show)

parseRel :: Text -> Either Text LinkRelation
parseRel :: Text -> Either Text LinkRelation
parseRel Text
t =
    case ByteString -> Maybe LinkRelation
fromByteString (ByteString -> Maybe LinkRelation)
-> ByteString -> Maybe LinkRelation
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
t of
        Maybe LinkRelation
Nothing -> Text -> Either Text LinkRelation
forall a b. a -> Either a b
Left Text
t
        Just LinkRelation
lr -> LinkRelation -> Either Text LinkRelation
forall a b. b -> Either a b
Right LinkRelation
lr

forF :: Functor f => f a -> (a -> b) -> f b
forF :: forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
forF = ((a -> b) -> f a -> f b) -> f a -> (a -> b) -> f b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

instance FromJSON Link where
    parseJSON :: Value -> Parser Link
parseJSON (Object Object
o) =
        Either Text LinkRelation
-> Maybe Text
-> Maybe Text
-> HashMap Language Text
-> HashMap Text (Maybe Text)
-> Link
Link (Either Text LinkRelation
 -> Maybe Text
 -> Maybe Text
 -> HashMap Language Text
 -> HashMap Text (Maybe Text)
 -> Link)
-> Parser (Either Text LinkRelation)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> HashMap Language Text
      -> HashMap Text (Maybe Text)
      -> Link)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"rel" Parser Text
-> (Text -> Either Text LinkRelation)
-> Parser (Either Text LinkRelation)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
`forF` Text -> Either Text LinkRelation
parseRel    Parser
  (Maybe Text
   -> Maybe Text
   -> HashMap Language Text
   -> HashMap Text (Maybe Text)
   -> Link)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> HashMap Language Text -> HashMap Text (Maybe Text) -> Link)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"type"                   Parser
  (Maybe Text
   -> HashMap Language Text -> HashMap Text (Maybe Text) -> Link)
-> Parser (Maybe Text)
-> Parser
     (HashMap Language Text -> HashMap Text (Maybe Text) -> Link)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"href"                   Parser (HashMap Language Text -> HashMap Text (Maybe Text) -> Link)
-> Parser (HashMap Language Text)
-> Parser (HashMap Text (Maybe Text) -> Link)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Object
o Object -> Key -> Parser (Maybe (HashMap Language Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"titles"     Parser (Maybe (HashMap Language Text))
-> HashMap Language Text -> Parser (HashMap Language Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= HashMap Language Text
forall k v. HashMap k v
M.empty Parser (HashMap Text (Maybe Text) -> Link)
-> Parser (HashMap Text (Maybe Text)) -> Parser Link
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Object
o Object -> Key -> Parser (Maybe (HashMap Text (Maybe Text)))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"properties" Parser (Maybe (HashMap Text (Maybe Text)))
-> HashMap Text (Maybe Text) -> Parser (HashMap Text (Maybe Text))
forall a. Parser (Maybe a) -> a -> Parser a
.!= HashMap Text (Maybe Text)
forall k v. HashMap k v
M.empty
    parseJSON Value
v          = String -> Value -> Parser Link
forall a. String -> Value -> Parser a
typeMismatch String
"Link" Value
v

-- | Information about the target resource, returned when a query succeeds.
data Description = Description
    { -- | A URI representing the resource being described. This is the same
      -- resource specified in the query, but the URI may slightly differ (e.g.
      -- appear in canonical form).
      Description -> Maybe Text
desSubject    :: Maybe Text
      -- | List of URIs which identify the same resource as the 'desSubject'
      -- URI.
    , Description -> [Text]
desAliases    :: [Text]
      -- | Additional information about the subject. Maps property names, which
      -- are URIs, to string values.
    , Description -> HashMap Text (Maybe Text)
desProperties :: HashMap Text (Maybe Text) --TODO use IANA database to parse known values?
      -- | Links of various relation types from the subject resource to other
      -- resources represented by URIs.
    , Description -> [Link]
desLinks      :: [Link]
    }
    deriving (Int -> Description -> ShowS
[Description] -> ShowS
Description -> String
(Int -> Description -> ShowS)
-> (Description -> String)
-> ([Description] -> ShowS)
-> Show Description
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Description -> ShowS
showsPrec :: Int -> Description -> ShowS
$cshow :: Description -> String
show :: Description -> String
$cshowList :: [Description] -> ShowS
showList :: [Description] -> ShowS
Show)

instance FromJSON Description where
    parseJSON :: Value -> Parser Description
parseJSON (Object Object
o) =
        Maybe Text
-> [Text] -> HashMap Text (Maybe Text) -> [Link] -> Description
Description (Maybe Text
 -> [Text] -> HashMap Text (Maybe Text) -> [Link] -> Description)
-> Parser (Maybe Text)
-> Parser
     ([Text] -> HashMap Text (Maybe Text) -> [Link] -> Description)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"subject"                Parser
  ([Text] -> HashMap Text (Maybe Text) -> [Link] -> Description)
-> Parser [Text]
-> Parser (HashMap Text (Maybe Text) -> [Link] -> Description)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Object
o Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"aliases"    Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []      Parser (HashMap Text (Maybe Text) -> [Link] -> Description)
-> Parser (HashMap Text (Maybe Text))
-> Parser ([Link] -> Description)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Object
o Object -> Key -> Parser (Maybe (HashMap Text (Maybe Text)))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"properties" Parser (Maybe (HashMap Text (Maybe Text)))
-> HashMap Text (Maybe Text) -> Parser (HashMap Text (Maybe Text))
forall a. Parser (Maybe a) -> a -> Parser a
.!= HashMap Text (Maybe Text)
forall k v. HashMap k v
M.empty Parser ([Link] -> Description)
-> Parser [Link] -> Parser Description
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Object
o Object -> Key -> Parser (Maybe [Link])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"links"      Parser (Maybe [Link]) -> [Link] -> Parser [Link]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    parseJSON Value
v          = String -> Value -> Parser Description
forall a. String -> Value -> Parser a
typeMismatch String
"Description" Value
v

-- | Response to the query.
data Result
    -- | The WebFinger server returned a valid resource description.
    = Success Description
    -- | The server returned a description but we failed to parse it.
    | InvalidDesc String
    -- | The server doesn't have information about the query target.
    | NoInfoFound
    -- | The server says the target URI is either absent from the HTTP request,
    -- or is malformed.
    | TargetMalformed
    -- | We (client side) couldn't determine the host to which to send the
    -- query. This usually means no host was explicitly specified, and the
    -- attempt to extract the host from the query target resource failed.
    | HostNotDetected String
    deriving (Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> String
show :: Result -> String
$cshowList :: [Result] -> ShowS
showList :: [Result] -> ShowS
Show)

-- | A connection manager, see "Network.HTTP.Client" for details. This function
-- creates a manager which can handle HTTPS, which is /required/ for WebFinger
-- and regular HTTP /isn't allowed/. If you'd like to make queries in other
-- ways which require more support (e.g. perhaps Tor), create your own manager
-- instead using one of the @http-client-*@ packages.
newManager :: IO H.Manager
newManager :: IO Manager
newManager = ManagerSettings -> IO Manager
H.newManager ManagerSettings
H.tlsManagerSettings

-- | Try to get the host from a resource URI.
getHost :: U.URI -> Either String ByteString
getHost :: URI -> Either String ByteString
getHost URI
uri =
    case URI -> Maybe Authority
U.uriAuthority URI
uri of
        Maybe Authority
Nothing -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Resource URI has no authority part"
        Just Authority
au -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Host -> ByteString
U.hostBS (Host -> ByteString) -> Host -> ByteString
forall a b. (a -> b) -> a -> b
$ Authority -> Host
U.authorityHost Authority
au

-- | Determine URI and host from resource. If no host is found, return a
-- message instead which explains why.
parseResource :: Resource -> (ByteString, Either String ByteString)
parseResource :: Resource -> (ByteString, Either String ByteString)
parseResource (ResAccount Account
a) =
    ( ByteString
"acct:" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Account -> ByteString
acctUser Account
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"@" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Account -> ByteString
acctHost Account
a -- escape user! do i need to espcape host?
    , ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Account -> ByteString
acctHost Account
a                         -- do i need to escape host? does http-client do it anyway?
    )
parseResource (ResUri URI
u) =
    ( URI -> ByteString
forall a. URIRef a -> ByteString
U.serializeURIRef' URI
u
    , URI -> Either String ByteString
getHost URI
u
    )
parseResource (ResUriStr ByteString
s) =
    let prefix :: ByteString
prefix = ByteString
"acct:"
        s' :: ByteString
s' = if Char
':' Char -> ByteString -> Bool
`BC.notElem` ByteString
s Bool -> Bool -> Bool
&& Char
'@' Char -> ByteString -> Bool
`BC.elem` ByteString
s
                then ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
s
                else ByteString
s
        rest :: ByteString
rest = Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
prefix) ByteString
s'
        needSlash :: Bool
needSlash = Bool -> Bool
not (ByteString -> Bool
B.null ByteString
rest) Bool -> Bool -> Bool
&& ByteString -> Char
BC.head ByteString
rest Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/'
        s'' :: ByteString
s'' = if ByteString
prefix ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
s' Bool -> Bool -> Bool
&& Bool
needSlash
                then ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"//" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
rest
                else ByteString
s'
    in  ( ByteString
s'
        , case URIParserOptions -> ByteString -> Either URIParseError URI
U.parseURI URIParserOptions
U.laxURIParserOptions ByteString
s'' of
            Left URIParseError
e    -> String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ URIParseError -> String
forall a. Show a => a -> String
show URIParseError
e
            Right URI
uri -> URI -> Either String ByteString
getHost URI
uri
        )

-- | Send a WebFinger query over HTTPS to a WebFinger server, and get a
-- response.
--
-- Some HTTP exceptions which represent common query results are caught and
-- used to determine the return value, i.e. the 'Result'. All other HTTP
-- exceptions aren't handled.
webfinger :: H.Manager
          -- ^ Connection manager. See 'newManager'.
          -> Query
          -- ^ A query expressing what you'd like to know, and whom to ask.
          -> IO Result
webfinger :: Manager -> Query -> IO Result
webfinger Manager
manager Query
q =
    let (ByteString
uri, Either String ByteString
eith) = Resource -> (ByteString, Either String ByteString)
parseResource (Resource -> (ByteString, Either String ByteString))
-> Resource -> (ByteString, Either String ByteString)
forall a b. (a -> b) -> a -> b
$ Query -> Resource
qryTarget Query
q
        eith' :: Either String ByteString
eith' = Either String ByteString
-> (ByteString -> Either String ByteString)
-> Maybe ByteString
-> Either String ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either String ByteString
eith ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Maybe ByteString -> Either String ByteString)
-> Maybe ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Query -> Maybe ByteString
qryHost Query
q
    in  case Either String ByteString
eith' of
            Left String
err -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
HostNotDetected String
err
            Right ByteString
host -> do
                let req :: Request
req = Request
H.defaultRequest
                        { method :: ByteString
H.method         = ByteString
HT.methodGet
                        , secure :: Bool
H.secure         = Bool
True
                        , host :: ByteString
H.host           = ByteString
host
                        , port :: Int
H.port           = Int
443
                        , path :: ByteString
H.path           = ByteString
"/.well-known/webfinger" --TODO maybe make a Haskell package for well-known URIs?
                        , requestHeaders :: RequestHeaders
H.requestHeaders =
                            [(HeaderName
HT.hAccept, ByteString
"application/jrd+json")]
                        }
                    req' :: Request
req' = case Query -> Maybe Auth
qryAuth Query
q of
                            Maybe Auth
Nothing               -> Request
req
                            Just (Auth ByteString
user ByteString
pass) -> ByteString -> ByteString -> Request -> Request
H.applyBasicAuth ByteString
user ByteString
pass Request
req
                    res :: (ByteString, Maybe ByteString)
res = (ByteString
"resource", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
uri)
                    toBS :: Either ByteString LinkRelation -> ByteString
toBS = (ByteString -> ByteString)
-> (LinkRelation -> ByteString)
-> Either ByteString LinkRelation
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ByteString -> ByteString
forall a. a -> a
id LinkRelation -> ByteString
toByteString
                    rels :: [(ByteString, Maybe ByteString)]
rels = (Either ByteString LinkRelation -> (ByteString, Maybe ByteString))
-> [Either ByteString LinkRelation]
-> [(ByteString, Maybe ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) ByteString
"rel" (Maybe ByteString -> (ByteString, Maybe ByteString))
-> (Either ByteString LinkRelation -> Maybe ByteString)
-> Either ByteString LinkRelation
-> (ByteString, Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Either ByteString LinkRelation -> ByteString)
-> Either ByteString LinkRelation
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ByteString LinkRelation -> ByteString
toBS) ([Either ByteString LinkRelation]
 -> [(ByteString, Maybe ByteString)])
-> [Either ByteString LinkRelation]
-> [(ByteString, Maybe ByteString)]
forall a b. (a -> b) -> a -> b
$ Query -> [Either ByteString LinkRelation]
qryLinkRels Query
q
                    params :: [(ByteString, Maybe ByteString)]
params = (ByteString, Maybe ByteString)
res (ByteString, Maybe ByteString)
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
forall a. a -> [a] -> [a]
: [(ByteString, Maybe ByteString)]
rels
                    req'' :: Request
req'' = [(ByteString, Maybe ByteString)] -> Request -> Request
H.setQueryString [(ByteString, Maybe ByteString)]
params Request
req'
                Either HttpException (Response ByteString)
eresp <- IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (Request -> Manager -> IO (Response ByteString)
H.httpLbs Request
req'' Manager
manager)
                case Either HttpException (Response ByteString)
eresp of
                    Left HttpException
e ->
                        case HttpException
e :: H.HttpException of
                            H.HttpExceptionRequest Request
_ (H.StatusCodeException Response ()
resp ByteString
_)
                                | Response () -> Status
forall body. Response body -> Status
H.responseStatus Response ()
resp Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
HT.badRequest400 -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
TargetMalformed
                                | Response () -> Status
forall body. Response body -> Status
H.responseStatus Response ()
resp Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
HT.notFound404   -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoInfoFound
                                | Bool
otherwise                                 -> HttpException -> IO Result
forall e a. Exception e => e -> IO a
throwIO HttpException
e
                            HttpException
_ -> HttpException -> IO Result
forall e a. Exception e => e -> IO a
throwIO HttpException
e
                    Right Response ByteString
resp ->
                        Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either String Description
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String Description)
-> ByteString -> Either String Description
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
H.responseBody Response ByteString
resp of
                            Left String
err   -> String -> Result
InvalidDesc String
err
                            Right Description
desc -> Description -> Result
Success Description
desc