{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Matrix.Identity
(
IdentitySession,
MatrixToken (..),
getTokenFromEnv,
createIdentitySession,
MatrixIO,
MatrixError (..),
retry,
retryWithLog,
UserID (..),
getIdentityTokenOwner,
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
data IdentitySession = IdentitySession
{ IdentitySession -> Text
baseUrl :: Text,
IdentitySession -> MatrixToken
token :: MatrixToken,
IdentitySession -> Manager
manager :: HTTP.Manager
}
createIdentitySession ::
Text ->
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 :: 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"
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)
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
]
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