{-# 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 (..), Value (Object), eitherDecode, (.:), (.:?))
import Data.ByteString.Lazy (ByteString, toStrict)
import Data.Hashable (Hashable)
import Data.Maybe (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

getTokenFromEnv ::
  -- | The envirnoment variable name
  Text ->
  IO MatrixToken
getTokenFromEnv :: Text -> IO MatrixToken
getTokenFromEnv Text
env = Text -> MatrixToken
MatrixToken (Text -> MatrixToken) -> (String -> Text) -> String -> MatrixToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> MatrixToken) -> IO String -> IO MatrixToken
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 =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
200 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
500) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ByteString
chunk <- BodyReader -> Int -> IO ByteString
HTTP.brReadSome (Response BodyReader -> BodyReader
forall body. Response body -> body
HTTP.responseBody Response BodyReader
res) Int
1024
    Request -> Response BodyReader -> ByteString -> IO ()
forall body a. Request -> Response body -> ByteString -> IO a
throwResponseError Request
req Response BodyReader
res ByteString
chunk
  where
    Status Int
code ByteString
_ = Response BodyReader -> Status
forall body. Response body -> Status
HTTP.responseStatus Response BodyReader
res

throwResponseError :: HTTP.Request -> HTTP.Response body -> ByteString -> IO a
throwResponseError :: Request -> Response body -> ByteString -> IO a
throwResponseError Request
req Response body
res ByteString
chunk =
  HttpException -> IO a
forall e a. Exception e => e -> IO a
throwIO (HttpException -> IO a) -> HttpException -> IO a
forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HTTP.HttpExceptionRequest Request
req HttpExceptionContent
ex
  where
    ex :: HttpExceptionContent
ex = Response () -> ByteString -> HttpExceptionContent
HTTP.StatusCodeException (Response body -> Response ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Response body
res) (ByteString -> ByteString
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 <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseUrlThrow (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
  Request -> IO Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$
    Request
initRequest
      { requestHeaders :: RequestHeaders
HTTP.requestHeaders =
          [(HeaderName
"Content-Type", ByteString
"application/json")] RequestHeaders -> RequestHeaders -> RequestHeaders
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", ByteString
"Bearer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 Text
token) | Bool
auth]

doRequest' :: FromJSON a => HTTP.Manager -> HTTP.Request -> IO (Either MatrixError a)
doRequest' :: 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 ByteString -> Either String (Either MatrixError a)
forall a.
FromJSON a =>
ByteString -> Either String (Either MatrixError a)
decodeResp (ByteString -> Either String (Either MatrixError a))
-> ByteString -> Either String (Either MatrixError a)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
response of
    Right Either MatrixError a
x -> Either MatrixError a -> IO (Either MatrixError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either MatrixError a
x
    Left String
e -> if Status -> Bool
statusIsSuccessful (Status -> Bool) -> Status -> Bool
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ByteString
response
      then String -> IO (Either MatrixError a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
      else Request
-> Response ByteString -> ByteString -> IO (Either MatrixError a)
forall body a. Request -> Response body -> ByteString -> IO a
throwResponseError Request
request Response ByteString
response (Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
response)

decodeResp :: FromJSON a => ByteString -> Either String (Either MatrixError a)
decodeResp :: ByteString -> Either String (Either MatrixError a)
decodeResp ByteString
resp = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
resp of
  Right a
a -> Either MatrixError a -> Either String (Either MatrixError a)
forall a b. b -> Either a b
Right (Either MatrixError a -> Either String (Either MatrixError a))
-> Either MatrixError a -> Either String (Either MatrixError a)
forall a b. (a -> b) -> a -> b
$ a -> Either MatrixError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Left String
e -> case ByteString -> Either String MatrixError
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
resp of
    Right MatrixError
me -> Either MatrixError a -> Either String (Either MatrixError a)
forall a b. b -> Either a b
Right (Either MatrixError a -> Either String (Either MatrixError a))
-> Either MatrixError a -> Either String (Either MatrixError a)
forall a b. (a -> b) -> a -> b
$ MatrixError -> Either MatrixError a
forall a b. a -> Either a b
Left MatrixError
me
    Left String
_ -> String -> Either String (Either MatrixError a)
forall a b. a -> Either a b
Left String
e

newtype UserID = UserID Text deriving (Int -> UserID -> ShowS
[UserID] -> ShowS
UserID -> String
(Int -> UserID -> ShowS)
-> (UserID -> String) -> ([UserID] -> ShowS) -> Show UserID
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
(UserID -> UserID -> Bool)
-> (UserID -> UserID -> Bool) -> Eq UserID
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
Eq UserID
-> (UserID -> UserID -> Ordering)
-> (UserID -> UserID -> Bool)
-> (UserID -> UserID -> Bool)
-> (UserID -> UserID -> Bool)
-> (UserID -> UserID -> Bool)
-> (UserID -> UserID -> UserID)
-> (UserID -> UserID -> UserID)
-> Ord 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
$cp1Ord :: Eq UserID
Ord, Int -> UserID -> Int
UserID -> Int
(Int -> UserID -> Int) -> (UserID -> Int) -> Hashable UserID
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: UserID -> Int
$chash :: UserID -> Int
hashWithSalt :: Int -> UserID -> Int
$chashWithSalt :: Int -> UserID -> Int
Hashable)

instance FromJSON UserID where
  parseJSON :: Value -> Parser UserID
parseJSON (Object Object
v) = Text -> UserID
UserID (Text -> UserID) -> Parser Text -> Parser UserID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"user_id"
  parseJSON Value
_ = Parser UserID
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
(Int -> MatrixError -> ShowS)
-> (MatrixError -> String)
-> ([MatrixError] -> ShowS)
-> Show MatrixError
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
(MatrixError -> MatrixError -> Bool)
-> (MatrixError -> MatrixError -> Bool) -> Eq MatrixError
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
(Int -> MatrixException -> ShowS)
-> (MatrixException -> String)
-> ([MatrixException] -> ShowS)
-> Show MatrixException
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
      (Text -> Text -> Maybe Int -> MatrixError)
-> Parser Text -> Parser (Text -> Maybe Int -> MatrixError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"errcode"
      Parser (Text -> Maybe Int -> MatrixError)
-> Parser Text -> Parser (Maybe Int -> MatrixError)
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
"error"
      Parser (Maybe Int -> MatrixError)
-> Parser (Maybe Int) -> Parser MatrixError
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"retry_after_ms"
  parseJSON Value
_ = Parser MatrixError
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 :: Int -> (Text -> m ()) -> MatrixM m a -> MatrixM m a
retryWithLog Int
limit Text -> m ()
logRetry MatrixM m a
action =
  RetryPolicyM m
-> [RetryStatus -> Handler m Bool]
-> (RetryStatus -> MatrixM m a)
-> MatrixM m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
Retry.recovering
    (Int -> RetryPolicy
Retry.exponentialBackoff Int
backoff RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
Retry.limitRetries Int
limit)
    [RetryStatus -> Handler m Bool
handler, RetryStatus -> Handler m Bool
forall (m :: * -> *) p. Applicative m => p -> Handler m Bool
rateLimitHandler]
    (MatrixM m a -> RetryStatus -> MatrixM m a
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 (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"RateLimit: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (delay: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
delayMS) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
5_000 Maybe Int
delayMS Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
          MatrixException -> MatrixM m a
forall a e. Exception e => e -> a
throw MatrixException
MatrixRateLimit
        Either MatrixError a
_ -> Either MatrixError a -> MatrixM m 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
_ = (MatrixException -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((MatrixException -> m Bool) -> Handler m Bool)
-> (MatrixException -> m Bool) -> Handler m Bool
forall a b. (a -> b) -> a -> b
$ \case
      MatrixException
MatrixRateLimit -> Bool -> m Bool
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
_) = (HttpException -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((HttpException -> m Bool) -> Handler m Bool)
-> (HttpException -> m Bool) -> Handler m Bool
forall a b. (a -> b) -> a -> b
$ \case
      HTTP.HttpExceptionRequest Request
req HttpExceptionContent
ctx -> do
        let url :: Text
url = ByteString -> Text
decodeUtf8 (Request -> ByteString
HTTP.host Request
req) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Int -> String
forall a. Show a => a -> String
show (Request -> Int
HTTP.port Request
req)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 (Request -> ByteString
HTTP.path Request
req)
            arg :: Text
arg = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.queryString Request
req
            loc :: Text
loc = if Int
num Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arg else Text
url
        Text -> m ()
logRetry (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
          Text
"NetworkFailure: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Int -> String
forall a. Show a => a -> String
show Int
num)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/5 "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
loc
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
ctx)
        Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      HTTP.InvalidUrlException String
_ String
_ -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

retry :: MatrixIO a -> MatrixIO a
retry :: MatrixIO a -> MatrixIO a
retry = Int -> (Text -> IO ()) -> MatrixIO a -> MatrixIO a
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
Int -> (Text -> m ()) -> MatrixM m a -> MatrixM m a
retryWithLog Int
7 (Handle -> Text -> IO ()
hPutStrLn Handle
stderr)