{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiWayIf #-}
module Discord.Internal.Rest.HTTP
( restLoop
, Request(..)
, JsonRequest(..)
, RestCallInternalException(..)
) where
import Prelude hiding (log)
import Data.Semigroup ((<>))
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent (threadDelay)
import Control.Exception.Safe (try)
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Data.Ix (inRange)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Text.Read (readMaybe)
import Data.Maybe (fromMaybe)
import qualified Network.HTTP.Req as R
import qualified Data.Map.Strict as M
import Discord.Internal.Types
import Discord.Internal.Rest.Prelude
data RestCallInternalException = RestCallInternalErrorCode Int B.ByteString B.ByteString
| RestCallInternalNoParse String BL.ByteString
| RestCallInternalHttpException R.HttpException
deriving (Show)
restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString))
-> Chan T.Text -> IO ()
restLoop auth urls log = loop M.empty
where
loop ratelocker = do
threadDelay (40 * 1000)
(route, request, thread) <- readChan urls
curtime <- getPOSIXTime
case compareRate ratelocker route curtime of
Locked -> do writeChan urls (route, request, thread)
loop ratelocker
Available -> do let action = compileRequest auth request
reqIO <- try $ restIOtoIO (tryRequest log action)
case reqIO :: Either R.HttpException (RequestResponse, Timeout) of
Left e -> do
writeChan log ("rest - http exception " <> T.pack (show e))
putMVar thread (Left (RestCallInternalHttpException e))
loop ratelocker
Right (resp, retry) -> do
case resp of
ResponseByteString "" -> putMVar thread (Right "[]")
ResponseByteString bs -> putMVar thread (Right bs)
ResponseErrorCode e s b ->
putMVar thread (Left (RestCallInternalErrorCode e s b))
ResponseTryAgain -> writeChan urls (route, request, thread)
case retry of
GlobalWait i -> do
writeChan log ("rest - GLOBAL WAIT LIMIT: "
<> T.pack (show ((i - curtime) * 1000)))
threadDelay $ round ((i - curtime + 0.1) * 1000)
loop ratelocker
PathWait i -> loop $ M.insert route i (removeAllExpire ratelocker curtime)
NoLimit -> loop ratelocker
data RateLimited = Available | Locked
compareRate :: M.Map String POSIXTime -> String -> POSIXTime -> RateLimited
compareRate ratelocker route curtime =
case M.lookup route ratelocker of
Just unlockTime -> if curtime < unlockTime then Locked else Available
Nothing -> Available
removeAllExpire :: M.Map String POSIXTime -> POSIXTime -> M.Map String POSIXTime
removeAllExpire ratelocker curtime =
if M.size ratelocker > 100 then M.filter (> curtime) ratelocker
else ratelocker
data RequestResponse = ResponseTryAgain
| ResponseByteString BL.ByteString
| ResponseErrorCode Int B.ByteString B.ByteString
deriving (Show)
data Timeout = GlobalWait POSIXTime
| PathWait POSIXTime
| NoLimit
tryRequest :: Chan T.Text -> RestIO R.LbsResponse -> RestIO (RequestResponse, Timeout)
tryRequest _log action = do
resp <- action
now <- liftIO getPOSIXTime
let body = R.responseBody resp
code = R.responseStatusCode resp
status = R.responseStatusMessage resp
global = (Just "true" ==) $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global"
remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Remaining"
reset = withDelta . fromMaybe 10 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Reset-After"
withDelta :: Double -> POSIXTime
withDelta dt = now + fromRational (toRational dt)
if | code == 429 -> pure (ResponseTryAgain, if global then GlobalWait reset
else PathWait reset)
| code `elem` [500,502] -> pure (ResponseTryAgain, NoLimit)
| inRange (200,299) code -> pure ( ResponseByteString body
, if remain > 0 then NoLimit else PathWait reset )
| inRange (400,499) code -> pure (ResponseErrorCode code status (BL.toStrict body)
, if remain > 0 then NoLimit else PathWait reset )
| otherwise -> pure (ResponseErrorCode code status (BL.toStrict body), NoLimit)
readMaybeBS :: Read a => B.ByteString -> Maybe a
readMaybeBS = readMaybe . T.unpack . TE.decodeUtf8
compileRequest :: Auth -> JsonRequest -> RestIO R.LbsResponse
compileRequest auth request = action
where
authopt = authHeader auth <> R.header "X-RateLimit-Precision" "millisecond"
action = case request of
(Delete url opts) -> R.req R.DELETE url R.NoReqBody R.lbsResponse (authopt <> opts)
(Get url opts) -> R.req R.GET url R.NoReqBody R.lbsResponse (authopt <> opts)
(Put url body opts) -> R.req R.PUT url body R.lbsResponse (authopt <> opts)
(Patch url body opts) -> do b <- body
R.req R.PATCH url b R.lbsResponse (authopt <> opts)
(Post url body opts) -> do b <- body
R.req R.POST url b R.lbsResponse (authopt <> opts)