Internal.hs

{-# LANGUAGE DeriveGeneric #-}
{-# 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 GHC.Generics (Generic)
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), eitherDecode, encode, object, (.:), (.=), defaultOptions, Options (..), camelTo2, genericParseJSON)
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)
import Data.Char (isUpper)

newtype MatrixToken = MatrixToken Text
newtype Username = Username {username :: Text}
newtype DeviceId = DeviceId {deviceId :: Text}
newtype InitialDeviceDisplayName = InitialDeviceDisplayName {initialDeviceDisplayName :: Text}
data LoginSecret = Password Text | Token Text

-- https://spec.matrix.org/v1.17/client-server-api/#post_matrixclientv3login
data LoginResponse = LoginResponse
    { lrAccessToken :: Text
    , lrDeviceId :: Text
    , lrExpiresInMs :: Maybe Int    -- Added in v1.3
    , lrHomeServer :: Maybe Text
    , lrRefreshToken :: Maybe Text  -- Added in v1.3
    , lrUserId :: Text
    } deriving (Generic, Show)

instance FromJSON LoginResponse where
    parseJSON = genericParseJSON aesonOptions

getTokenFromEnv ::
    -- | The envirnoment variable name
    Text ->
    IO MatrixToken
getTokenFromEnv env = MatrixToken . pack <$> getEnv (unpack env)

mkManager :: IO HTTP.Manager
mkManager = HTTP.newManager tlsManagerSettings

checkMatrixResponse :: HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO ()
checkMatrixResponse req res =
    unless (200 <= code && code < 500) $ do
        chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024
        throwResponseError req res chunk
  where
    Status code _ = HTTP.responseStatus res

throwResponseError :: HTTP.Request -> HTTP.Response body -> ByteString -> IO a
throwResponseError req res chunk =
    throwIO $ HTTP.HttpExceptionRequest req ex
  where
    ex = HTTP.StatusCodeException (void res) (toStrict chunk)

mkRequest' :: Text -> MatrixToken -> Bool -> Text -> IO HTTP.Request
mkRequest' baseUrl (MatrixToken token) auth path = do
    initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path)
    pure $
        initRequest
            { HTTP.requestHeaders =
                [("Content-Type", "application/json")] <> authHeaders
            , HTTP.checkResponse = checkMatrixResponse
            }
  where
    authHeaders =
        [("Authorization", "Bearer " <> encodeUtf8 token) | auth]

-- https://spec.matrix.org/v1.17/client-server-api/#post_matrixclientv3login
mkLoginRequest' :: Text -> Maybe DeviceId -> Maybe InitialDeviceDisplayName -> Bool -> Username -> LoginSecret -> IO HTTP.Request
mkLoginRequest' baseUrl did idn enableRefreshTokens (Username name) secret' = do
    let path = "/_matrix/client/v3/login"
    initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path)

    let (secretKey, secret, secretType) = case secret' of
            Password pass -> ("password", pass, "m.login.password")
            Token tok -> ("token", tok, "m.login.token")

    let body =
            HTTP.RequestBodyLBS $
                encode $
                    object $
                        [ "identifier" .= object ["type" .= ("m.id.user" :: Text), "user" .= name]
                        , secretKey .= secret
                        , "refresh_token" .= enableRefreshTokens    -- Added in v1.3
                        , "type" .= (secretType :: Text)
                        ]
                            <> catMaybes
                                [ fmap (("device_id" .=) . deviceId) did
                                , fmap (("initial_device_display_name" .=) . initialDeviceDisplayName) idn
                                ]

    pure $ initRequest{HTTP.method = "POST", HTTP.requestBody = body, HTTP.requestHeaders = [("Content-Type", "application/json")]}

mkLogoutRequest' :: Text -> MatrixToken -> IO HTTP.Request
mkLogoutRequest' baseUrl (MatrixToken token) = do
    let path = "/_matrix/client/v3/logout"
    initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path)
    let headers = [("Authorization", encodeUtf8 $ "Bearer " <> token)]
    pure $ initRequest{HTTP.method = "POST", HTTP.requestHeaders = headers}

doRequest' :: (FromJSON a) => HTTP.Manager -> HTTP.Request -> IO (Either MatrixError a)
doRequest' manager request = do
    response <- HTTP.httpLbs request manager
    case decodeResp $ HTTP.responseBody response of
        Right x -> pure x
        Left e ->
            if statusIsSuccessful $ HTTP.responseStatus response
                then fail e
                else throwResponseError request response (HTTP.responseBody response)

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

newtype UserID = UserID Text
    deriving (Show, Eq, Ord, Hashable, FromJSONKey)

instance FromJSON UserID where
    parseJSON (Object v) = UserID <$> v .: "user_id"
    parseJSON _ = mzero

data MatrixError = MatrixError
    { meErrcode :: Text
    , meError :: Text
    , meRetryAfterMS :: Maybe Int
    }
    deriving (Generic, Show, Eq)

instance FromJSON MatrixError where
    parseJSON = genericParseJSON aesonOptions

data MatrixException = MatrixRateLimit deriving (Show)

instance Exception MatrixException

-- | '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 limit logRetry action =
    Retry.recovering
        (Retry.exponentialBackoff backoff <> Retry.limitRetries limit)
        [handler, rateLimitHandler]
        (const checkAction)
  where
    checkAction = do
        res <- action
        case res of
            Left (MatrixError "M_LIMIT_EXCEEDED" err delayMS) -> do
                -- Reponse contains a retry_after_ms
                logRetry $ "RateLimit: " <> err <> " (delay: " <> pack (show delayMS) <> ")"
                liftIO $ threadDelay $ fromMaybe 5_000 delayMS * 1000
                throw MatrixRateLimit
            _ -> pure res

    backoff = 1_000_000 -- 1sec
    rateLimitHandler _ = Handler $ \case
        MatrixRateLimit -> pure True
    -- Log network error
    handler (RetryStatus num _ _) = Handler $ \case
        HTTP.HttpExceptionRequest req ctx -> do
            let url = decodeUtf8 (HTTP.host req) <> ":" <> pack (show (HTTP.port req)) <> decodeUtf8 (HTTP.path req)
                arg = decodeUtf8 $ HTTP.queryString req
                loc = if num == 0 then url <> arg else url
            logRetry $
                "NetworkFailure: "
                    <> pack (show num)
                    <> "/5 "
                    <> loc
                    <> " failed: "
                    <> pack (show ctx)
            pure True
        HTTP.InvalidUrlException _ _ -> pure False

retry :: (MonadIO m, MonadMask m) => MatrixM m a -> MatrixM m a
retry = retryWithLog 7 (liftIO . hPutStrLn stderr)

-------------------------------------------------------------------------------
-- Utils

aesonOptions :: Options
aesonOptions = defaultOptions
    { fieldLabelModifier = camelTo2 '_' . dropPrefix
    , omitNothingFields = True
    }
    where
        -- drops lower case prefix
        dropPrefix :: String -> String
        dropPrefix []                 = []
        dropPrefix (x:xs) | isUpper x = x : xs
                          | otherwise = dropPrefix xs