{-# 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 (..), 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 ::
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
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 :: 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
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
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
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)