{-# LANGUAGE CPP #-}
{-# 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)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
#endif
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

#if MIN_VERSION_aeson(2,0,0)
toKVList :: KeyMap.KeyMap v -> [(Text, v)]
toKVList :: forall v. KeyMap v -> [(Text, v)]
toKVList = forall k v. HashMap k v -> [(k, v)]
HM.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. KeyMap v -> HashMap Text v
KeyMap.toHashMapText
#else
toKVList :: HM.HashMap Text v -> [(Text, v)]
toKVList = HM.toList
#endif

-- $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' 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 :: forall a. FromJSON a => IdentitySession -> Request -> MatrixIO a
doRequest IdentitySession {Text
Manager
MatrixToken
manager :: Manager
token :: MatrixToken
baseUrl :: Text
manager :: IdentitySession -> Manager
token :: IdentitySession -> MatrixToken
baseUrl :: IdentitySession -> Text
..} = 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 =
  forall a. FromJSON a => IdentitySession -> Request -> MatrixIO a
doRequest IdentitySession
session 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
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
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"algorithms" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"lookup_pepper"
  parseJSON Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero

hashDetails :: IdentitySession -> MatrixIO HashDetails
hashDetails :: IdentitySession -> MatrixIO HashDetails
hashDetails IdentitySession
session =
  forall a. FromJSON a => IdentitySession -> Request -> MatrixIO a
doRequest IdentitySession
session 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
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IdentityLookupResponse -> Maybe UserID
toUserIDM forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdentitySession
-> IdentityLookupRequest -> MatrixIO 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
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
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
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
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
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 forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"mappings"
    case Value
mappings of
      (Object Object
kv) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(HashedAddress, UserID)] -> IdentityLookupResponse
IdentityLookupResponse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Value) -> Maybe (HashedAddress, UserID)
toTuple (forall v. KeyMap v -> [(Text, v)]
toKVList Object
kv)
      Value
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
    where
      toTuple :: (Text, Value) -> Maybe (HashedAddress, UserID)
toTuple (Text
k, String Text
s) = forall a. a -> Maybe a
Just (Text -> HashedAddress
HashedAddress Text
k, Text -> UserID
UserID Text
s)
      toTuple (Text, Value)
_ = forall a. Maybe a
Nothing
  parseJSON Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero

identitiesLookup :: IdentitySession -> IdentityLookupRequest -> MatrixIO IdentityLookupResponse
identitiesLookup :: IdentitySession
-> IdentityLookupRequest -> MatrixIO IdentityLookupResponse
identitiesLookup IdentitySession
session IdentityLookupRequest
ilr = do
  Request
request <- IdentitySession -> Bool -> Text -> IO Request
mkRequest IdentitySession
session Bool
True Text
"/_matrix/identity/v2/lookup"
  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 =
      forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$
        [Pair] -> Value
object
          [ Key
"addresses" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map HashedAddress -> Text
getAddr (IdentityLookupRequest -> [HashedAddress]
ilrAddresses IdentityLookupRequest
ilr),
            Key
"algorithm" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= IdentityLookupRequest -> Text
ilrHash IdentityLookupRequest
ilr,
            Key
"pepper" forall kv v. (KeyValue kv, ToJSON v) => Key -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeBase64Unpadded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Digest t -> ByteString
bytestringDigest forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA256State
sha256 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> ByteString
fromStrict 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
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
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 forall a b. (a -> b) -> a -> b
$ Text -> Text
encodeSHA256 forall a b. (a -> b) -> a -> b
$ Text
val forall a. Semigroup a => a -> a -> a
<> 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 forall a. Semigroup a => a -> a -> a
<> Text
" email"
      Msisdn Text
x -> Text
x 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" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` HashDetails -> NonEmpty Text
hdAlgorithms HashDetails
hd
        then Text
"sha256"
        else 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) = forall a b. Eq a => a -> [(a, b)] -> Maybe b
Data.List.lookup HashedAddress
x [(HashedAddress, UserID)]
xs