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

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

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

-- | 'MatrixIO' is a convenient type alias for server response
type MatrixIO a = IO (Either MatrixError a)

-- | Retry 5 times network action, doubling backoff each time
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 -- 500ms
    -- 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
        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