{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiWayIf #-}
module Discord.Internal.Rest.HTTP
( restLoop
, Request(..)
, JsonRequest(..)
, RestCallInternalException(..)
) where
import Prelude hiding (log)
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 (Int -> RestCallInternalException -> ShowS
[RestCallInternalException] -> ShowS
RestCallInternalException -> String
(Int -> RestCallInternalException -> ShowS)
-> (RestCallInternalException -> String)
-> ([RestCallInternalException] -> ShowS)
-> Show RestCallInternalException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RestCallInternalException] -> ShowS
$cshowList :: [RestCallInternalException] -> ShowS
show :: RestCallInternalException -> String
$cshow :: RestCallInternalException -> String
showsPrec :: Int -> RestCallInternalException -> ShowS
$cshowsPrec :: Int -> RestCallInternalException -> ShowS
Show)
restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString))
-> Chan T.Text -> IO ()
restLoop :: Auth
-> Chan
(String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
-> Chan Text
-> IO ()
restLoop Auth
auth Chan
(String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
urls Chan Text
log = Map String POSIXTime -> IO ()
forall b. Map String POSIXTime -> IO b
loop Map String POSIXTime
forall k a. Map k a
M.empty
where
loop :: Map String POSIXTime -> IO b
loop Map String POSIXTime
ratelocker = do
Int -> IO ()
threadDelay (Int
40 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
(String
route, JsonRequest
request, MVar (Either RestCallInternalException ByteString)
thread) <- Chan
(String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
-> IO
(String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
forall a. Chan a -> IO a
readChan Chan
(String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
urls
POSIXTime
curtime <- IO POSIXTime
getPOSIXTime
case Map String POSIXTime -> String -> POSIXTime -> RateLimited
compareRate Map String POSIXTime
ratelocker String
route POSIXTime
curtime of
RateLimited
Locked -> do Chan
(String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
-> (String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
-> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan
(String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
urls (String
route, JsonRequest
request, MVar (Either RestCallInternalException ByteString)
thread)
Map String POSIXTime -> IO b
loop Map String POSIXTime
ratelocker
RateLimited
Available -> do let action :: RestIO LbsResponse
action = Auth -> JsonRequest -> RestIO LbsResponse
compileRequest Auth
auth JsonRequest
request
Either HttpException (RequestResponse, Timeout)
reqIO <- IO (RequestResponse, Timeout)
-> IO (Either HttpException (RequestResponse, Timeout))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO (RequestResponse, Timeout)
-> IO (Either HttpException (RequestResponse, Timeout)))
-> IO (RequestResponse, Timeout)
-> IO (Either HttpException (RequestResponse, Timeout))
forall a b. (a -> b) -> a -> b
$ RestIO (RequestResponse, Timeout) -> IO (RequestResponse, Timeout)
forall a. RestIO a -> IO a
restIOtoIO (Chan Text
-> RestIO LbsResponse -> RestIO (RequestResponse, Timeout)
tryRequest Chan Text
log RestIO LbsResponse
action)
case Either HttpException (RequestResponse, Timeout)
reqIO :: Either R.HttpException (RequestResponse, Timeout) of
Left HttpException
e -> do
Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"rest - http exception " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (HttpException -> String
forall a. Show a => a -> String
show HttpException
e))
MVar (Either RestCallInternalException ByteString)
-> Either RestCallInternalException ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either RestCallInternalException ByteString)
thread (RestCallInternalException
-> Either RestCallInternalException ByteString
forall a b. a -> Either a b
Left (HttpException -> RestCallInternalException
RestCallInternalHttpException HttpException
e))
Map String POSIXTime -> IO b
loop Map String POSIXTime
ratelocker
Right (RequestResponse
resp, Timeout
retry) -> do
case RequestResponse
resp of
ResponseByteString ByteString
"" -> MVar (Either RestCallInternalException ByteString)
-> Either RestCallInternalException ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either RestCallInternalException ByteString)
thread (ByteString -> Either RestCallInternalException ByteString
forall a b. b -> Either a b
Right ByteString
"[]")
ResponseByteString ByteString
bs -> MVar (Either RestCallInternalException ByteString)
-> Either RestCallInternalException ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either RestCallInternalException ByteString)
thread (ByteString -> Either RestCallInternalException ByteString
forall a b. b -> Either a b
Right ByteString
bs)
ResponseErrorCode Int
e ByteString
s ByteString
b ->
MVar (Either RestCallInternalException ByteString)
-> Either RestCallInternalException ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either RestCallInternalException ByteString)
thread (RestCallInternalException
-> Either RestCallInternalException ByteString
forall a b. a -> Either a b
Left (Int -> ByteString -> ByteString -> RestCallInternalException
RestCallInternalErrorCode Int
e ByteString
s ByteString
b))
RequestResponse
ResponseTryAgain -> Chan
(String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
-> (String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
-> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan
(String, JsonRequest,
MVar (Either RestCallInternalException ByteString))
urls (String
route, JsonRequest
request, MVar (Either RestCallInternalException ByteString)
thread)
case Timeout
retry of
GlobalWait POSIXTime
i -> do
Chan Text -> Text -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Text
log (Text
"rest - GLOBAL WAIT LIMIT: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (POSIXTime -> String
forall a. Show a => a -> String
show ((POSIXTime
i POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
curtime) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000)))
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ((POSIXTime
i POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
curtime POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
0.1) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000)
Map String POSIXTime -> IO b
loop Map String POSIXTime
ratelocker
PathWait POSIXTime
i -> Map String POSIXTime -> IO b
loop (Map String POSIXTime -> IO b) -> Map String POSIXTime -> IO b
forall a b. (a -> b) -> a -> b
$ String -> POSIXTime -> Map String POSIXTime -> Map String POSIXTime
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
route POSIXTime
i (Map String POSIXTime -> POSIXTime -> Map String POSIXTime
removeAllExpire Map String POSIXTime
ratelocker POSIXTime
curtime)
Timeout
NoLimit -> Map String POSIXTime -> IO b
loop Map String POSIXTime
ratelocker
data RateLimited = Available | Locked
compareRate :: M.Map String POSIXTime -> String -> POSIXTime -> RateLimited
compareRate :: Map String POSIXTime -> String -> POSIXTime -> RateLimited
compareRate Map String POSIXTime
ratelocker String
route POSIXTime
curtime =
case String -> Map String POSIXTime -> Maybe POSIXTime
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
route Map String POSIXTime
ratelocker of
Just POSIXTime
unlockTime -> if POSIXTime
curtime POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
< POSIXTime
unlockTime then RateLimited
Locked else RateLimited
Available
Maybe POSIXTime
Nothing -> RateLimited
Available
removeAllExpire :: M.Map String POSIXTime -> POSIXTime -> M.Map String POSIXTime
removeAllExpire :: Map String POSIXTime -> POSIXTime -> Map String POSIXTime
removeAllExpire Map String POSIXTime
ratelocker POSIXTime
curtime =
if Map String POSIXTime -> Int
forall k a. Map k a -> Int
M.size Map String POSIXTime
ratelocker Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
100 then (POSIXTime -> Bool) -> Map String POSIXTime -> Map String POSIXTime
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
> POSIXTime
curtime) Map String POSIXTime
ratelocker
else Map String POSIXTime
ratelocker
data RequestResponse = ResponseTryAgain
| ResponseByteString BL.ByteString
| ResponseErrorCode Int B.ByteString B.ByteString
deriving (Int -> RequestResponse -> ShowS
[RequestResponse] -> ShowS
RequestResponse -> String
(Int -> RequestResponse -> ShowS)
-> (RequestResponse -> String)
-> ([RequestResponse] -> ShowS)
-> Show RequestResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestResponse] -> ShowS
$cshowList :: [RequestResponse] -> ShowS
show :: RequestResponse -> String
$cshow :: RequestResponse -> String
showsPrec :: Int -> RequestResponse -> ShowS
$cshowsPrec :: Int -> RequestResponse -> ShowS
Show)
data Timeout = GlobalWait POSIXTime
| PathWait POSIXTime
| NoLimit
tryRequest :: Chan T.Text -> RestIO R.LbsResponse -> RestIO (RequestResponse, Timeout)
tryRequest :: Chan Text
-> RestIO LbsResponse -> RestIO (RequestResponse, Timeout)
tryRequest Chan Text
_log RestIO LbsResponse
action = do
LbsResponse
resp <- RestIO LbsResponse
action
POSIXTime
now <- IO POSIXTime -> RestIO POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
let body :: HttpResponseBody LbsResponse
body = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
R.responseBody LbsResponse
resp
code :: Int
code = LbsResponse -> Int
forall response. HttpResponse response => response -> Int
R.responseStatusCode LbsResponse
resp
status :: ByteString
status = LbsResponse -> ByteString
forall response. HttpResponse response => response -> ByteString
R.responseStatusMessage LbsResponse
resp
global :: Bool
global = (String -> Maybe String
forall a. a -> Maybe a
Just (String
"true" :: String) Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe String
forall a. Read a => ByteString -> Maybe a
readMaybeBS (ByteString -> Maybe String) -> Maybe ByteString -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LbsResponse -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
R.responseHeader LbsResponse
resp ByteString
"X-RateLimit-Global"
remain :: Integer
remain = Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
1 (Maybe Integer -> Integer) -> Maybe Integer -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Integer
forall a. Read a => ByteString -> Maybe a
readMaybeBS (ByteString -> Maybe Integer) -> Maybe ByteString -> Maybe Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LbsResponse -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
R.responseHeader LbsResponse
resp ByteString
"X-RateLimit-Remaining" :: Integer
reset :: POSIXTime
reset = Double -> POSIXTime
withDelta (Double -> POSIXTime)
-> (Maybe Double -> Double) -> Maybe Double -> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
10 (Maybe Double -> POSIXTime) -> Maybe Double -> POSIXTime
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Double
forall a. Read a => ByteString -> Maybe a
readMaybeBS (ByteString -> Maybe Double) -> Maybe ByteString -> Maybe Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LbsResponse -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
R.responseHeader LbsResponse
resp ByteString
"X-RateLimit-Reset-After"
withDelta :: Double -> POSIXTime
withDelta :: Double -> POSIXTime
withDelta Double
dt = POSIXTime
now POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ Rational -> POSIXTime
forall a. Fractional a => Rational -> a
fromRational (Double -> Rational
forall a. Real a => a -> Rational
toRational Double
dt)
if | Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
429 -> (RequestResponse, Timeout) -> RestIO (RequestResponse, Timeout)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestResponse
ResponseTryAgain, if Bool
global then POSIXTime -> Timeout
GlobalWait POSIXTime
reset
else POSIXTime -> Timeout
PathWait POSIXTime
reset)
| Int
code Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
500,Int
502] -> (RequestResponse, Timeout) -> RestIO (RequestResponse, Timeout)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestResponse
ResponseTryAgain, Timeout
NoLimit)
| (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
200,Int
299) Int
code -> (RequestResponse, Timeout) -> RestIO (RequestResponse, Timeout)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( ByteString -> RequestResponse
ResponseByteString ByteString
body
, if Integer
remain Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 then Timeout
NoLimit else POSIXTime -> Timeout
PathWait POSIXTime
reset )
| (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
400,Int
499) Int
code -> (RequestResponse, Timeout) -> RestIO (RequestResponse, Timeout)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ByteString -> ByteString -> RequestResponse
ResponseErrorCode Int
code ByteString
status (ByteString -> ByteString
BL.toStrict ByteString
body)
, if Integer
remain Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 then Timeout
NoLimit else POSIXTime -> Timeout
PathWait POSIXTime
reset )
| Bool
otherwise -> (RequestResponse, Timeout) -> RestIO (RequestResponse, Timeout)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ByteString -> ByteString -> RequestResponse
ResponseErrorCode Int
code ByteString
status (ByteString -> ByteString
BL.toStrict ByteString
body), Timeout
NoLimit)
readMaybeBS :: Read a => B.ByteString -> Maybe a
readMaybeBS :: ByteString -> Maybe a
readMaybeBS = String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a)
-> (ByteString -> String) -> ByteString -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8
compileRequest :: Auth -> JsonRequest -> RestIO R.LbsResponse
compileRequest :: Auth -> JsonRequest -> RestIO LbsResponse
compileRequest Auth
auth JsonRequest
request = RestIO LbsResponse
action
where
authopt :: Option 'Https
authopt = Auth -> Option 'Https
authHeader Auth
auth Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> Option 'Https
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
R.header ByteString
"X-RateLimit-Precision" ByteString
"millisecond"
action :: RestIO LbsResponse
action = case JsonRequest
request of
(Delete Url 'Https
url Option 'Https
opts) -> DELETE
-> Url 'Https
-> NoReqBody
-> Proxy LbsResponse
-> Option 'Https
-> RestIO LbsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
R.req DELETE
R.DELETE Url 'Https
url NoReqBody
R.NoReqBody Proxy LbsResponse
R.lbsResponse (Option 'Https
authopt Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> Option 'Https
opts)
(Get Url 'Https
url Option 'Https
opts) -> GET
-> Url 'Https
-> NoReqBody
-> Proxy LbsResponse
-> Option 'Https
-> RestIO LbsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
R.req GET
R.GET Url 'Https
url NoReqBody
R.NoReqBody Proxy LbsResponse
R.lbsResponse (Option 'Https
authopt Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> Option 'Https
opts)
(Put Url 'Https
url a
body Option 'Https
opts) -> PUT
-> Url 'Https
-> a
-> Proxy LbsResponse
-> Option 'Https
-> RestIO LbsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
R.req PUT
R.PUT Url 'Https
url a
body Proxy LbsResponse
R.lbsResponse (Option 'Https
authopt Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> Option 'Https
opts)
(Patch Url 'Https
url RestIO a
body Option 'Https
opts) -> do a
b <- RestIO a
body
PATCH
-> Url 'Https
-> a
-> Proxy LbsResponse
-> Option 'Https
-> RestIO LbsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
R.req PATCH
R.PATCH Url 'Https
url a
b Proxy LbsResponse
R.lbsResponse (Option 'Https
authopt Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> Option 'Https
opts)
(Post Url 'Https
url RestIO a
body Option 'Https
opts) -> do a
b <- RestIO a
body
POST
-> Url 'Https
-> a
-> Proxy LbsResponse
-> Option 'Https
-> RestIO LbsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
R.req POST
R.POST Url 'Https
url a
b Proxy LbsResponse
R.lbsResponse (Option 'Https
authopt Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> Option 'Https
opts)