{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Network.Matrix.Internal where
import Control.Concurrent (threadDelay)
import Control.Exception (Exception, throw, throwIO)
import Control.Monad (mzero, unless, void)
import Control.Monad.Catch (Handler (Handler), MonadMask)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Retry (RetryStatus (..))
import qualified Control.Retry as Retry
import Data.Aeson (FromJSON (..), FromJSONKey (..), Value (Object), encode, eitherDecode, object, withObject, (.:), (.:?), (.=))
import Data.ByteString.Lazy (ByteString, toStrict)
import Data.Hashable (Hashable)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text.IO (hPutStrLn)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (Status (..))
import Network.HTTP.Types.Status (statusIsSuccessful)
import System.Environment (getEnv)
import System.IO (stderr)
newtype MatrixToken = MatrixToken Text
newtype Username = Username { Username -> Text
username :: Text }
newtype DeviceId = DeviceId { DeviceId -> Text
deviceId :: Text }
newtype InitialDeviceDisplayName = InitialDeviceDisplayName { InitialDeviceDisplayName -> Text
initialDeviceDisplayName :: Text}
data LoginSecret = Password Text | Token Text
data LoginResponse = LoginResponse
{ LoginResponse -> Text
lrUserId :: Text
, LoginResponse -> Text
lrAccessToken :: Text
, LoginResponse -> Text
lrHomeServer :: Text
, LoginResponse -> Text
lrDeviceId :: Text
}
instance FromJSON LoginResponse where
parseJSON :: Value -> Parser LoginResponse
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LoginResponse" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
Text
userId' <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"user_id"
Text
accessToken' <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"access_token"
Text
homeServer' <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"home_server"
Text
deviceId' <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"device_id"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text -> LoginResponse
LoginResponse Text
userId' Text
accessToken' Text
homeServer' Text
deviceId'
getTokenFromEnv ::
Text ->
IO MatrixToken
getTokenFromEnv :: Text -> IO MatrixToken
getTokenFromEnv Text
env = Text -> MatrixToken
MatrixToken forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
getEnv (Text -> String
unpack Text
env)
mkManager :: IO HTTP.Manager
mkManager :: IO Manager
mkManager = ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
tlsManagerSettings
checkMatrixResponse :: HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO ()
checkMatrixResponse :: Request -> Response BodyReader -> IO ()
checkMatrixResponse Request
req Response BodyReader
res =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
200 forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
< Int
500) forall a b. (a -> b) -> a -> b
$ do
ByteString
chunk <- BodyReader -> Int -> IO ByteString
HTTP.brReadSome (forall body. Response body -> body
HTTP.responseBody Response BodyReader
res) Int
1024
forall body a. Request -> Response body -> ByteString -> IO a
throwResponseError Request
req Response BodyReader
res ByteString
chunk
where
Status Int
code Method
_ = forall body. Response body -> Status
HTTP.responseStatus Response BodyReader
res
throwResponseError :: HTTP.Request -> HTTP.Response body -> ByteString -> IO a
throwResponseError :: forall body a. Request -> Response body -> ByteString -> IO a
throwResponseError Request
req Response body
res ByteString
chunk =
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HTTP.HttpExceptionRequest Request
req HttpExceptionContent
ex
where
ex :: HttpExceptionContent
ex = Response () -> Method -> HttpExceptionContent
HTTP.StatusCodeException (forall (f :: * -> *) a. Functor f => f a -> f ()
void Response body
res) (ByteString -> Method
toStrict ByteString
chunk)
mkRequest' :: Text -> MatrixToken -> Bool -> Text -> IO HTTP.Request
mkRequest' :: Text -> MatrixToken -> Bool -> Text -> IO Request
mkRequest' Text
baseUrl (MatrixToken Text
token) Bool
auth Text
path = do
Request
initRequest <- forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseUrlThrow (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ Text
baseUrl forall a. Semigroup a => a -> a -> a
<> Text
path)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Request
initRequest
{ requestHeaders :: RequestHeaders
HTTP.requestHeaders =
[(HeaderName
"Content-Type", Method
"application/json")] forall a. Semigroup a => a -> a -> a
<> RequestHeaders
authHeaders,
checkResponse :: Request -> Response BodyReader -> IO ()
HTTP.checkResponse = Request -> Response BodyReader -> IO ()
checkMatrixResponse
}
where
authHeaders :: RequestHeaders
authHeaders =
[(HeaderName
"Authorization", Method
"Bearer " forall a. Semigroup a => a -> a -> a
<> Text -> Method
encodeUtf8 Text
token) | Bool
auth]
mkLoginRequest' :: Text -> Maybe DeviceId -> Maybe InitialDeviceDisplayName -> Username -> LoginSecret -> IO HTTP.Request
mkLoginRequest' :: Text
-> Maybe DeviceId
-> Maybe InitialDeviceDisplayName
-> Username
-> LoginSecret
-> IO Request
mkLoginRequest' Text
baseUrl Maybe DeviceId
did Maybe InitialDeviceDisplayName
idn (Username Text
name) LoginSecret
secret' = do
let path :: Text
path = Text
"/_matrix/client/r0/login"
Request
initRequest <- forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseUrlThrow (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ Text
baseUrl forall a. Semigroup a => a -> a -> a
<> Text
path)
let (Key
secretKey, Text
secret, Text
secretType) = case LoginSecret
secret' of
Password Text
pass -> (Key
"password", Text
pass, Text
"m.login.password")
Token Text
tok -> (Key
"token", Text
tok, Text
"m.login.token")
let body :: RequestBody
body = ByteString -> RequestBody
HTTP.RequestBodyLBS forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$
[ Key
"identifier" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"m.id.user" :: Text), Key
"user" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name ]
, Key
secretKey forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
secret
, Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
secretType :: Text)
] forall a. Semigroup a => a -> a -> a
<> forall a. [Maybe a] -> [a]
catMaybes [ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key
"device_id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeviceId -> Text
deviceId) Maybe DeviceId
did
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key
"initial_device_display_name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitialDeviceDisplayName -> Text
initialDeviceDisplayName) Maybe InitialDeviceDisplayName
idn
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Request
initRequest { method :: Method
HTTP.method = Method
"POST", requestBody :: RequestBody
HTTP.requestBody = RequestBody
body, requestHeaders :: RequestHeaders
HTTP.requestHeaders = [(HeaderName
"Content-Type", Method
"application/json")] }
mkLogoutRequest' :: Text -> MatrixToken -> IO HTTP.Request
mkLogoutRequest' :: Text -> MatrixToken -> IO Request
mkLogoutRequest' Text
baseUrl (MatrixToken Text
token) = do
let path :: Text
path = Text
"/_matrix/client/r0/logout"
Request
initRequest <- forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseUrlThrow (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ Text
baseUrl forall a. Semigroup a => a -> a -> a
<> Text
path)
let headers :: RequestHeaders
headers = [(HeaderName
"Authorization", Text -> Method
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text
"Bearer " forall a. Semigroup a => a -> a -> a
<> Text
token)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Request
initRequest { method :: Method
HTTP.method = Method
"POST", requestHeaders :: RequestHeaders
HTTP.requestHeaders = RequestHeaders
headers }
doRequest' :: FromJSON a => HTTP.Manager -> HTTP.Request -> IO (Either MatrixError a)
doRequest' :: forall a.
FromJSON a =>
Manager -> Request -> IO (Either MatrixError a)
doRequest' Manager
manager Request
request = do
Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
request Manager
manager
case forall a.
FromJSON a =>
ByteString -> Either String (Either MatrixError a)
decodeResp forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
HTTP.responseBody Response ByteString
response of
Right Either MatrixError a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Either MatrixError a
x
Left String
e -> if Status -> Bool
statusIsSuccessful forall a b. (a -> b) -> a -> b
$ forall body. Response body -> Status
HTTP.responseStatus Response ByteString
response
then forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
else forall body a. Request -> Response body -> ByteString -> IO a
throwResponseError Request
request Response ByteString
response (forall body. Response body -> body
HTTP.responseBody Response ByteString
response)
decodeResp :: FromJSON a => ByteString -> Either String (Either MatrixError a)
decodeResp :: forall a.
FromJSON a =>
ByteString -> Either String (Either MatrixError a)
decodeResp ByteString
resp = case forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
resp of
Right a
a -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left String
e -> case forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
resp of
Right MatrixError
me -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left MatrixError
me
Left String
_ -> forall a b. a -> Either a b
Left String
e
newtype UserID = UserID Text
deriving (Int -> UserID -> ShowS
[UserID] -> ShowS
UserID -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserID] -> ShowS
$cshowList :: [UserID] -> ShowS
show :: UserID -> String
$cshow :: UserID -> String
showsPrec :: Int -> UserID -> ShowS
$cshowsPrec :: Int -> UserID -> ShowS
Show, UserID -> UserID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserID -> UserID -> Bool
$c/= :: UserID -> UserID -> Bool
== :: UserID -> UserID -> Bool
$c== :: UserID -> UserID -> Bool
Eq, Eq UserID
UserID -> UserID -> Bool
UserID -> UserID -> Ordering
UserID -> UserID -> UserID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UserID -> UserID -> UserID
$cmin :: UserID -> UserID -> UserID
max :: UserID -> UserID -> UserID
$cmax :: UserID -> UserID -> UserID
>= :: UserID -> UserID -> Bool
$c>= :: UserID -> UserID -> Bool
> :: UserID -> UserID -> Bool
$c> :: UserID -> UserID -> Bool
<= :: UserID -> UserID -> Bool
$c<= :: UserID -> UserID -> Bool
< :: UserID -> UserID -> Bool
$c< :: UserID -> UserID -> Bool
compare :: UserID -> UserID -> Ordering
$ccompare :: UserID -> UserID -> Ordering
Ord, Eq UserID
Int -> UserID -> Int
UserID -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: UserID -> Int
$chash :: UserID -> Int
hashWithSalt :: Int -> UserID -> Int
$chashWithSalt :: Int -> UserID -> Int
Hashable, FromJSONKeyFunction [UserID]
FromJSONKeyFunction UserID
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [UserID]
$cfromJSONKeyList :: FromJSONKeyFunction [UserID]
fromJSONKey :: FromJSONKeyFunction UserID
$cfromJSONKey :: FromJSONKeyFunction UserID
FromJSONKey)
instance FromJSON UserID where
parseJSON :: Value -> Parser UserID
parseJSON (Object Object
v) = Text -> UserID
UserID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"user_id"
parseJSON Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero
data MatrixError = MatrixError
{ MatrixError -> Text
meErrcode :: Text,
MatrixError -> Text
meError :: Text,
MatrixError -> Maybe Int
meRetryAfterMS :: Maybe Int
}
deriving (Int -> MatrixError -> ShowS
[MatrixError] -> ShowS
MatrixError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MatrixError] -> ShowS
$cshowList :: [MatrixError] -> ShowS
show :: MatrixError -> String
$cshow :: MatrixError -> String
showsPrec :: Int -> MatrixError -> ShowS
$cshowsPrec :: Int -> MatrixError -> ShowS
Show, MatrixError -> MatrixError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MatrixError -> MatrixError -> Bool
$c/= :: MatrixError -> MatrixError -> Bool
== :: MatrixError -> MatrixError -> Bool
$c== :: MatrixError -> MatrixError -> Bool
Eq)
data MatrixException = MatrixRateLimit deriving (Int -> MatrixException -> ShowS
[MatrixException] -> ShowS
MatrixException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MatrixException] -> ShowS
$cshowList :: [MatrixException] -> ShowS
show :: MatrixException -> String
$cshow :: MatrixException -> String
showsPrec :: Int -> MatrixException -> ShowS
$cshowsPrec :: Int -> MatrixException -> ShowS
Show)
instance Exception MatrixException
instance FromJSON MatrixError where
parseJSON :: Value -> Parser MatrixError
parseJSON (Object Object
v) =
Text -> Text -> Maybe Int -> MatrixError
MatrixError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"errcode"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"error"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"retry_after_ms"
parseJSON Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero
type MatrixIO a = MatrixM IO a
type MatrixM m a = m (Either MatrixError a)
retryWithLog ::
(MonadMask m, MonadIO m) =>
Int ->
(Text -> m ()) ->
MatrixM m a ->
MatrixM m a
retryWithLog :: forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
Int -> (Text -> m ()) -> MatrixM m a -> MatrixM m a
retryWithLog Int
limit Text -> m ()
logRetry MatrixM m a
action =
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
Retry.recovering
(forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
Retry.exponentialBackoff Int
backoff forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
Retry.limitRetries Int
limit)
[RetryStatus -> Handler m Bool
handler, forall {m :: * -> *} {p}. Applicative m => p -> Handler m Bool
rateLimitHandler]
(forall a b. a -> b -> a
const MatrixM m a
checkAction)
where
checkAction :: MatrixM m a
checkAction = do
Either MatrixError a
res <- MatrixM m a
action
case Either MatrixError a
res of
Left (MatrixError Text
"M_LIMIT_EXCEEDED" Text
err Maybe Int
delayMS) -> do
Text -> m ()
logRetry forall a b. (a -> b) -> a -> b
$ Text
"RateLimit: " forall a. Semigroup a => a -> a -> a
<> Text
err forall a. Semigroup a => a -> a -> a
<> Text
" (delay: " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Maybe Int
delayMS) forall a. Semigroup a => a -> a -> a
<> Text
")"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Int
5_000 Maybe Int
delayMS forall a. Num a => a -> a -> a
* Int
1000
forall a e. Exception e => e -> a
throw MatrixException
MatrixRateLimit
Either MatrixError a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Either MatrixError a
res
backoff :: Int
backoff = Int
1000000
rateLimitHandler :: p -> Handler m Bool
rateLimitHandler p
_ = forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \case
MatrixException
MatrixRateLimit -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
handler :: RetryStatus -> Handler m Bool
handler (RetryStatus Int
num Int
_ Maybe Int
_) = forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \case
HTTP.HttpExceptionRequest Request
req HttpExceptionContent
ctx -> do
let url :: Text
url = Method -> Text
decodeUtf8 (Request -> Method
HTTP.host Request
req) forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show (Request -> Int
HTTP.port Request
req)) forall a. Semigroup a => a -> a -> a
<> Method -> Text
decodeUtf8 (Request -> Method
HTTP.path Request
req)
arg :: Text
arg = Method -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ Request -> Method
HTTP.queryString Request
req
loc :: Text
loc = if Int
num forall a. Eq a => a -> a -> Bool
== Int
0 then Text
url forall a. Semigroup a => a -> a -> a
<> Text
arg else Text
url
Text -> m ()
logRetry forall a b. (a -> b) -> a -> b
$
Text
"NetworkFailure: "
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Int
num)
forall a. Semigroup a => a -> a -> a
<> Text
"/5 "
forall a. Semigroup a => a -> a -> a
<> Text
loc
forall a. Semigroup a => a -> a -> a
<> Text
" failed: "
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show HttpExceptionContent
ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
HTTP.InvalidUrlException String
_ String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
retry :: (MonadIO m, MonadMask m) => MatrixM m a -> MatrixM m a
retry :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
MatrixM m a -> MatrixM m a
retry = forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
Int -> (Text -> m ()) -> MatrixM m a -> MatrixM m a
retryWithLog Int
7 (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
hPutStrLn Handle
stderr)