{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}

-- | This module contains low-level HTTP utility
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 ::
  -- | The envirnoment variable name
  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

-- | 'MatrixIO' is a convenient type alias for server response
type MatrixIO a = MatrixM IO a

type MatrixM m a = m (Either MatrixError a)

-- | Retry a network action
retryWithLog ::
  (MonadMask m, MonadIO m) =>
  -- | Maximum number of retry
  Int ->
  -- | A log function, can be used to measure errors
  (Text -> m ()) ->
  -- | The action to retry
  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
          -- Reponse contains a retry_after_ms
          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 -- 1sec
    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
    -- Log network error
    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)