webfinger-client-0.2.1.0: src/Web/Finger/Client.hs
{- 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
{ acctUser :: 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
{ authUser :: 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.
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.
, 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.
, 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'.
, qryAuth :: Maybe Auth
}
instance Default Query where
def = Query
{ qryTarget = ResUriStr B.empty
, qryLinkRels = []
, qryHost = Nothing
, qryAuth = 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 (Eq, Generic, Show)
instance Hashable Language
instance FromJSON Language where
parseJSON (String t) = pure (toLang t)
parseJSON v = typeMismatch "Language" v
instance FromJSONKey Language where
fromJSONKey = FromJSONKeyText toLang
toLang :: Text -> Language
toLang t =
if t == "und"
then LanguageUndefined
else LanguageCode 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.
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).
, 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@.
, lnkAddress :: Maybe Text
-- | Optional title(s) for the link, possibly in various languages.
, lnkTitles :: HashMap Language Text
-- | Additional properties the link may have. Maps property names, which
-- are URIs, to string values.
, lnkProperties :: HashMap Text (Maybe Text) --TODO use IANA database to parse known values?
}
deriving (Show)
parseRel :: Text -> Either Text LinkRelation
parseRel t =
case fromByteString $ encodeUtf8 t of
Nothing -> Left t
Just lr -> Right lr
forF :: Functor f => f a -> (a -> b) -> f b
forF = flip fmap
instance FromJSON Link where
parseJSON (Object o) =
Link <$>
o .: "rel" `forF` parseRel <*>
o .:? "type" <*>
o .:? "href" <*>
o .:? "titles" .!= M.empty <*>
o .:? "properties" .!= M.empty
parseJSON v = typeMismatch "Link" 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).
desSubject :: Maybe Text
-- | List of URIs which identify the same resource as the 'desSubject'
-- URI.
, desAliases :: [Text]
-- | Additional information about the subject. Maps property names, which
-- are URIs, to string values.
, 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.
, desLinks :: [Link]
}
deriving (Show)
instance FromJSON Description where
parseJSON (Object o) =
Description <$>
o .:? "subject" <*>
o .:? "aliases" .!= [] <*>
o .:? "properties" .!= M.empty <*>
o .:? "links" .!= []
parseJSON v = typeMismatch "Description" 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 (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 = H.newManager H.tlsManagerSettings
-- | Try to get the host from a resource URI.
getHost :: U.URI -> Either String ByteString
getHost uri =
case U.uriAuthority uri of
Nothing -> Left "Resource URI has no authority part"
Just au -> Right $ U.hostBS $ U.authorityHost 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 (ResAccount a) =
( "acct:" <> acctUser a <> "@" <> acctHost a -- escape user! do i need to espcape host?
, Right $ acctHost a -- do i need to escape host? does http-client do it anyway?
)
parseResource (ResUri u) =
( U.serializeURIRef' u
, getHost u
)
parseResource (ResUriStr s) =
let prefix = "acct:"
s' = if ':' `BC.notElem` s && '@' `BC.elem` s
then prefix <> s
else s
rest = B.drop (B.length prefix) s'
needSlash = not (B.null rest) && BC.head rest /= '/'
s'' = if prefix `B.isPrefixOf` s' && needSlash
then prefix <> "//" <> rest
else s'
in ( s'
, case U.parseURI U.laxURIParserOptions s'' of
Left e -> Left $ show e
Right uri -> getHost 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 q =
let (uri, eith) = parseResource $ qryTarget q
eith' = maybe eith Right $ qryHost q
in case eith' of
Left err -> return $ HostNotDetected err
Right host -> do
let req = H.defaultRequest
{ H.method = HT.methodGet
, H.secure = True
, H.host = host
, H.port = 443
, H.path = "/.well-known/webfinger" --TODO maybe make a Haskell package for well-known URIs?
, H.requestHeaders =
[(HT.hAccept, "application/jrd+json")]
}
req' = case qryAuth q of
Nothing -> req
Just (Auth user pass) -> H.applyBasicAuth user pass req
res = ("resource", Just uri)
toBS = either id toByteString
rels = map ((,) "rel" . Just . toBS) $ qryLinkRels q
params = res : rels
req'' = H.setQueryString params req'
eresp <- try (H.httpLbs req'' manager)
case eresp of
Left e ->
case e :: H.HttpException of
H.HttpExceptionRequest _ (H.StatusCodeException resp _)
| H.responseStatus resp == HT.badRequest400 -> return TargetMalformed
| H.responseStatus resp == HT.notFound404 -> return NoInfoFound
| otherwise -> throwIO e
_ -> throwIO e
Right resp ->
return $ case eitherDecode $ H.responseBody resp of
Left err -> InvalidDesc err
Right desc -> Success desc