{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Network.Matrix.Internal where
import Control.Monad (mzero)
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)
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 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
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
}
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
Either MatrixError a -> IO (Either MatrixError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MatrixError a -> IO (Either MatrixError a))
-> Either MatrixError a -> IO (Either MatrixError a)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either MatrixError a
forall a. FromJSON a => ByteString -> Either MatrixError a
decodeResp (Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
response)
decodeResp :: FromJSON a => ByteString -> Either MatrixError a
decodeResp :: ByteString -> 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 -> a -> Either MatrixError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left String
err -> case ByteString -> Either String MatrixError
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
resp of
Right MatrixError
me -> MatrixError -> Either MatrixError a
forall a b. a -> Either a b
Left MatrixError
me
Left String
_ -> String -> Either MatrixError a
forall a. HasCallStack => String -> a
error (String -> Either MatrixError a) -> String -> Either MatrixError a
forall a b. (a -> b) -> a -> b
$ String
"Could not decode: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
newtype UserID = UserID Text deriving (Int -> UserID -> String -> String
[UserID] -> String -> String
UserID -> String
(Int -> UserID -> String -> String)
-> (UserID -> String)
-> ([UserID] -> String -> String)
-> Show UserID
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UserID] -> String -> String
$cshowList :: [UserID] -> String -> String
show :: UserID -> String
$cshow :: UserID -> String
showsPrec :: Int -> UserID -> String -> String
$cshowsPrec :: Int -> UserID -> String -> String
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)
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 -> String -> String
[MatrixError] -> String -> String
MatrixError -> String
(Int -> MatrixError -> String -> String)
-> (MatrixError -> String)
-> ([MatrixError] -> String -> String)
-> Show MatrixError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [MatrixError] -> String -> String
$cshowList :: [MatrixError] -> String -> String
show :: MatrixError -> String
$cshow :: MatrixError -> String
showsPrec :: Int -> MatrixError -> String -> String
$cshowsPrec :: Int -> MatrixError -> String -> String
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)
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 = IO (Either MatrixError a)
retry :: (MonadMask m, MonadIO m) => m a -> m a
retry :: m a -> m a
retry m a
action =
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> 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
5)
[RetryStatus -> Handler m Bool
forall (m :: * -> *). MonadIO m => RetryStatus -> Handler m Bool
handler]
(m a -> RetryStatus -> m a
forall a b. a -> b -> a
const m a
action)
where
backoff :: Int
backoff = Int
500000
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
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
Handle -> Text -> IO ()
hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
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