{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | This module contains the Identity service API
-- https://matrix.org/docs/spec/identity_service/r0.3.0.html
module Network.Matrix.Identity
  ( -- * Client
    IdentitySession,
    MatrixToken (..),
    getTokenFromEnv,
    createIdentitySession,

    -- * API
    MatrixIO,
    MatrixError (..),
    retry,
    retryWithLog,

    -- * User data
    UserID (..),
    getIdentityTokenOwner,

    -- * Association lookup
    HashDetails (..),
    hashDetails,
    Identity (..),
    identityLookup,
    HashedAddress,
    IdentityLookupRequest,
    IdentityLookupResponse,
    identitiesLookup,
    mkIdentityLookupRequest,
    toHashedAddress,
    lookupIdentity,
  )
where

import Control.Monad (mzero)
import Data.Aeson (FromJSON (..), Value (Object, String), encode, object, (.:), (.=))
import Data.ByteString.Lazy (fromStrict)
import Data.ByteString.Lazy.Base64.URL (encodeBase64Unpadded)
import Data.Digest.Pure.SHA (bytestringDigest, sha256)
import qualified Data.HashMap.Strict as HM
import Data.List (lookup)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Lazy (toStrict)
import qualified Network.HTTP.Client as HTTP
import Network.Matrix.Internal

-- $setup
-- >>> import Data.Aeson (decode)

-- | The session record, use 'createSession' to create it.
data IdentitySession = IdentitySession
  { IdentitySession -> Text
baseUrl :: Text,
    IdentitySession -> MatrixToken
token :: MatrixToken,
    IdentitySession -> Manager
manager :: HTTP.Manager
  }

-- | 'createSession' creates the session record.
createIdentitySession ::
  -- | The matrix identity base url, e.g. "https://matrix.org"
  Text ->
  -- | The user identity token
  MatrixToken ->
  IO IdentitySession
createIdentitySession :: Text -> MatrixToken -> IO IdentitySession
createIdentitySession Text
baseUrl' MatrixToken
token' = Text -> MatrixToken -> Manager -> IdentitySession
IdentitySession Text
baseUrl' MatrixToken
token' (Manager -> IdentitySession) -> IO Manager -> IO IdentitySession
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Manager
mkManager

mkRequest :: IdentitySession -> Bool -> Text -> IO HTTP.Request
mkRequest :: IdentitySession -> Bool -> Text -> IO Request
mkRequest IdentitySession {Text
Manager
MatrixToken
manager :: Manager
token :: MatrixToken
baseUrl :: Text
manager :: IdentitySession -> Manager
token :: IdentitySession -> MatrixToken
baseUrl :: IdentitySession -> Text
..} = Text -> MatrixToken -> Bool -> Text -> IO Request
mkRequest' Text
baseUrl MatrixToken
token

doRequest :: FromJSON a => IdentitySession -> HTTP.Request -> MatrixIO a
doRequest :: IdentitySession -> Request -> MatrixIO a
doRequest IdentitySession {Text
Manager
MatrixToken
manager :: Manager
token :: MatrixToken
baseUrl :: Text
manager :: IdentitySession -> Manager
token :: IdentitySession -> MatrixToken
baseUrl :: IdentitySession -> Text
..} = Manager -> Request -> MatrixIO a
forall a.
FromJSON a =>
Manager -> Request -> IO (Either MatrixError a)
doRequest' Manager
manager

-- | 'getIdentityTokenOwner' gets information about the owner of a given access token.
getIdentityTokenOwner :: IdentitySession -> MatrixIO UserID
getIdentityTokenOwner :: IdentitySession -> MatrixIO UserID
getIdentityTokenOwner IdentitySession
session =
  IdentitySession -> Request -> MatrixIO UserID
forall a. FromJSON a => IdentitySession -> Request -> MatrixIO a
doRequest IdentitySession
session (Request -> MatrixIO UserID) -> IO Request -> MatrixIO UserID
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IdentitySession -> Bool -> Text -> IO Request
mkRequest IdentitySession
session Bool
True Text
"/_matrix/identity/v2/account"

data HashDetails = HashDetails
  { HashDetails -> NonEmpty Text
hdAlgorithms :: NonEmpty Text,
    HashDetails -> Text
hdPepper :: Text
  }
  deriving (Int -> HashDetails -> ShowS
[HashDetails] -> ShowS
HashDetails -> String
(Int -> HashDetails -> ShowS)
-> (HashDetails -> String)
-> ([HashDetails] -> ShowS)
-> Show HashDetails
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HashDetails] -> ShowS
$cshowList :: [HashDetails] -> ShowS
show :: HashDetails -> String
$cshow :: HashDetails -> String
showsPrec :: Int -> HashDetails -> ShowS
$cshowsPrec :: Int -> HashDetails -> ShowS
Show, HashDetails -> HashDetails -> Bool
(HashDetails -> HashDetails -> Bool)
-> (HashDetails -> HashDetails -> Bool) -> Eq HashDetails
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HashDetails -> HashDetails -> Bool
$c/= :: HashDetails -> HashDetails -> Bool
== :: HashDetails -> HashDetails -> Bool
$c== :: HashDetails -> HashDetails -> Bool
Eq)

instance FromJSON HashDetails where
  parseJSON :: Value -> Parser HashDetails
parseJSON (Object Object
v) = NonEmpty Text -> Text -> HashDetails
HashDetails (NonEmpty Text -> Text -> HashDetails)
-> Parser (NonEmpty Text) -> Parser (Text -> HashDetails)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser (NonEmpty Text)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"algorithms" Parser (Text -> HashDetails) -> Parser Text -> Parser HashDetails
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"lookup_pepper"
  parseJSON Value
_ = Parser HashDetails
forall (m :: * -> *) a. MonadPlus m => m a
mzero

hashDetails :: IdentitySession -> MatrixIO HashDetails
hashDetails :: IdentitySession -> MatrixIO HashDetails
hashDetails IdentitySession
session =
  IdentitySession -> Request -> MatrixIO HashDetails
forall a. FromJSON a => IdentitySession -> Request -> MatrixIO a
doRequest IdentitySession
session (Request -> MatrixIO HashDetails)
-> IO Request -> MatrixIO HashDetails
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IdentitySession -> Bool -> Text -> IO Request
mkRequest IdentitySession
session Bool
True Text
"/_matrix/identity/v2/hash_details"

-- | Use 'identityLookup' to lookup a single identity, otherwise uses the full 'identitiesLookup'.
identityLookup :: IdentitySession -> HashDetails -> Identity -> MatrixIO (Maybe UserID)
identityLookup :: IdentitySession
-> HashDetails -> Identity -> MatrixIO (Maybe UserID)
identityLookup IdentitySession
session HashDetails
hd Identity
ident = do
  (IdentityLookupResponse -> Maybe UserID)
-> Either MatrixError IdentityLookupResponse
-> Either MatrixError (Maybe UserID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IdentityLookupResponse -> Maybe UserID
toUserIDM (Either MatrixError IdentityLookupResponse
 -> Either MatrixError (Maybe UserID))
-> IO (Either MatrixError IdentityLookupResponse)
-> MatrixIO (Maybe UserID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdentitySession
-> IdentityLookupRequest
-> IO (Either MatrixError IdentityLookupResponse)
identitiesLookup IdentitySession
session IdentityLookupRequest
ilr
  where
    toUserIDM :: IdentityLookupResponse -> Maybe UserID
toUserIDM = HashedAddress -> IdentityLookupResponse -> Maybe UserID
lookupIdentity HashedAddress
address
    address :: HashedAddress
address = HashDetails -> Identity -> HashedAddress
toHashedAddress HashDetails
hd Identity
ident
    ilr :: IdentityLookupRequest
ilr = HashDetails -> [HashedAddress] -> IdentityLookupRequest
mkIdentityLookupRequest HashDetails
hd [HashedAddress
address]

data IdentityLookupRequest = IdentityLookupRequest
  { IdentityLookupRequest -> Text
ilrHash :: Text,
    IdentityLookupRequest -> Text
ilrPepper :: Text,
    IdentityLookupRequest -> [HashedAddress]
ilrAddresses :: [HashedAddress]
  }
  deriving (Int -> IdentityLookupRequest -> ShowS
[IdentityLookupRequest] -> ShowS
IdentityLookupRequest -> String
(Int -> IdentityLookupRequest -> ShowS)
-> (IdentityLookupRequest -> String)
-> ([IdentityLookupRequest] -> ShowS)
-> Show IdentityLookupRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IdentityLookupRequest] -> ShowS
$cshowList :: [IdentityLookupRequest] -> ShowS
show :: IdentityLookupRequest -> String
$cshow :: IdentityLookupRequest -> String
showsPrec :: Int -> IdentityLookupRequest -> ShowS
$cshowsPrec :: Int -> IdentityLookupRequest -> ShowS
Show, IdentityLookupRequest -> IdentityLookupRequest -> Bool
(IdentityLookupRequest -> IdentityLookupRequest -> Bool)
-> (IdentityLookupRequest -> IdentityLookupRequest -> Bool)
-> Eq IdentityLookupRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IdentityLookupRequest -> IdentityLookupRequest -> Bool
$c/= :: IdentityLookupRequest -> IdentityLookupRequest -> Bool
== :: IdentityLookupRequest -> IdentityLookupRequest -> Bool
$c== :: IdentityLookupRequest -> IdentityLookupRequest -> Bool
Eq)

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

-- | A newtype wrapper to decoded nested list
--
-- >>> decode "{\"mappings\": {\"hash\": \"user\"}}" :: Maybe IdentityLookupResponse
-- Just (IdentityLookupResponse [(HashedAddress "hash",UserID "user")])
newtype IdentityLookupResponse = IdentityLookupResponse [(HashedAddress, UserID)]
  deriving (Int -> IdentityLookupResponse -> ShowS
[IdentityLookupResponse] -> ShowS
IdentityLookupResponse -> String
(Int -> IdentityLookupResponse -> ShowS)
-> (IdentityLookupResponse -> String)
-> ([IdentityLookupResponse] -> ShowS)
-> Show IdentityLookupResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IdentityLookupResponse] -> ShowS
$cshowList :: [IdentityLookupResponse] -> ShowS
show :: IdentityLookupResponse -> String
$cshow :: IdentityLookupResponse -> String
showsPrec :: Int -> IdentityLookupResponse -> ShowS
$cshowsPrec :: Int -> IdentityLookupResponse -> ShowS
Show)

instance FromJSON IdentityLookupResponse where
  parseJSON :: Value -> Parser IdentityLookupResponse
parseJSON (Object Object
v) = do
    Value
mappings <- Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"mappings"
    case Value
mappings of
      (Object Object
kv) -> IdentityLookupResponse -> Parser IdentityLookupResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdentityLookupResponse -> Parser IdentityLookupResponse)
-> ([(HashedAddress, UserID)] -> IdentityLookupResponse)
-> [(HashedAddress, UserID)]
-> Parser IdentityLookupResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(HashedAddress, UserID)] -> IdentityLookupResponse
IdentityLookupResponse ([(HashedAddress, UserID)] -> Parser IdentityLookupResponse)
-> [(HashedAddress, UserID)] -> Parser IdentityLookupResponse
forall a b. (a -> b) -> a -> b
$ ((Text, Value) -> Maybe (HashedAddress, UserID))
-> [(Text, Value)] -> [(HashedAddress, UserID)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Value) -> Maybe (HashedAddress, UserID)
toTuple (Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList Object
kv)
      Value
_ -> Parser IdentityLookupResponse
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    where
      toTuple :: (Text, Value) -> Maybe (HashedAddress, UserID)
toTuple (Text
k, String Text
s) = (HashedAddress, UserID) -> Maybe (HashedAddress, UserID)
forall a. a -> Maybe a
Just (Text -> HashedAddress
HashedAddress Text
k, Text -> UserID
UserID Text
s)
      toTuple (Text, Value)
_ = Maybe (HashedAddress, UserID)
forall a. Maybe a
Nothing
  parseJSON Value
_ = Parser IdentityLookupResponse
forall (m :: * -> *) a. MonadPlus m => m a
mzero

identitiesLookup :: IdentitySession -> IdentityLookupRequest -> MatrixIO IdentityLookupResponse
identitiesLookup :: IdentitySession
-> IdentityLookupRequest
-> IO (Either MatrixError IdentityLookupResponse)
identitiesLookup IdentitySession
session IdentityLookupRequest
ilr = do
  Request
request <- IdentitySession -> Bool -> Text -> IO Request
mkRequest IdentitySession
session Bool
True Text
"/_matrix/identity/v2/lookup"
  IdentitySession
-> Request -> IO (Either MatrixError IdentityLookupResponse)
forall a. FromJSON a => IdentitySession -> Request -> MatrixIO a
doRequest
    IdentitySession
session
    ( Request
request
        { method :: Method
HTTP.method = Method
"POST",
          requestBody :: RequestBody
HTTP.requestBody = ByteString -> RequestBody
HTTP.RequestBodyLBS ByteString
body
        }
    )
  where
    getAddr :: HashedAddress -> Text
getAddr (HashedAddress Text
x) = Text
x
    body :: ByteString
body =
      Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$
        [(Text, Value)] -> Value
object
          [ Text
"addresses" Text -> [Text] -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (HashedAddress -> Text) -> [HashedAddress] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map HashedAddress -> Text
getAddr (IdentityLookupRequest -> [HashedAddress]
ilrAddresses IdentityLookupRequest
ilr),
            Text
"algorithm" Text -> Text -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= IdentityLookupRequest -> Text
ilrHash IdentityLookupRequest
ilr,
            Text
"pepper" Text -> Text -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= IdentityLookupRequest -> Text
ilrPepper IdentityLookupRequest
ilr
          ]

-- | Hash encoding for lookup
-- >>> encodeSHA256 "alice@example.com email matrixrocks"
-- "4kenr7N9drpCJ4AfalmlGQVsOn3o2RHjkADUpXJWZUc"
encodeSHA256 :: Text -> Text
encodeSHA256 :: Text -> Text
encodeSHA256 = Text -> Text
toStrict (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeBase64Unpadded (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256State -> ByteString
forall t. Digest t -> ByteString
bytestringDigest (Digest SHA256State -> ByteString)
-> (Text -> Digest SHA256State) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA256State
sha256 (ByteString -> Digest SHA256State)
-> (Text -> ByteString) -> Text -> Digest SHA256State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> ByteString
fromStrict (Method -> ByteString) -> (Text -> Method) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Method
encodeUtf8

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

toHashedAddress :: HashDetails -> Identity -> HashedAddress
toHashedAddress :: HashDetails -> Identity -> HashedAddress
toHashedAddress HashDetails
hd Identity
ident = Text -> HashedAddress
HashedAddress (Text -> HashedAddress) -> Text -> HashedAddress
forall a b. (a -> b) -> a -> b
$ Text -> Text
encodeSHA256 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashDetails -> Text
hdPepper HashDetails
hd
  where
    val :: Text
val = case Identity
ident of
      Email Text
x -> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" email"
      Msisdn Text
x -> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" msisdn"

mkIdentityLookupRequest :: HashDetails -> [HashedAddress] -> IdentityLookupRequest
mkIdentityLookupRequest :: HashDetails -> [HashedAddress] -> IdentityLookupRequest
mkIdentityLookupRequest HashDetails
hd = Text -> Text -> [HashedAddress] -> IdentityLookupRequest
IdentityLookupRequest Text
hash (HashDetails -> Text
hdPepper HashDetails
hd)
  where
    hash :: Text
hash =
      if Text
"sha256" Text -> NonEmpty Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` HashDetails -> NonEmpty Text
hdAlgorithms HashDetails
hd
        then Text
"sha256"
        else String -> Text
forall a. HasCallStack => String -> a
error String
"Only sha256 is supported"

lookupIdentity :: HashedAddress -> IdentityLookupResponse -> Maybe UserID
lookupIdentity :: HashedAddress -> IdentityLookupResponse -> Maybe UserID
lookupIdentity HashedAddress
x (IdentityLookupResponse [(HashedAddress, UserID)]
xs) = HashedAddress -> [(HashedAddress, UserID)] -> Maybe UserID
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Data.List.lookup HashedAddress
x [(HashedAddress, UserID)]
xs