{-# 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

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
                            -- decode "[]" == () for expected empty calls
                            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)