1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiWayIf #-}
-- | Provide HTTP primitives
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
-- | An exception in a Rest call
data RestCallInternalException
-- | Error code from Discord
= RestCallInternalErrorCode Int B.ByteString B.ByteString
-- | Couldn't parse the response
| RestCallInternalNoParse String BL.ByteString
-- | Something went bad in the HTTP process
| RestCallInternalHttpException R.HttpException
deriving (Show)
-- | Rest event loop
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
-- decode "[]" == () for expected empty calls
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" :: String) ==) $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global"
remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Remaining" :: Integer
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)
|
