-- | Generic Request type
module Calamity.HTTP.Internal.Request (
  Request (..),
  invoke,
  getWith,
  postWith',
  postWithP',
  putWith',
  patchWith',
  putEmpty,
  putEmptyP,
  postEmpty,
  postEmptyP,
  getWithP,
  deleteWith,
  (=:?),
) where

import Calamity.HTTP.Internal.Ratelimit
import Calamity.HTTP.Internal.Route
import Calamity.HTTP.Internal.Types
import Calamity.Metrics.Eff
import Calamity.Types.LogEff (LogEff)
import Calamity.Types.Token
import Calamity.Types.TokenEff
import Control.Monad
import Data.Aeson hiding (Options)
import Data.Aeson.Types (parseEither)
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as T
import qualified Data.Text.Encoding as TS
import DiPolysemy hiding (debug, error, info)
import Network.HTTP.Req
import Optics
import qualified Polysemy as P
import qualified Polysemy.Error as P
import Web.HttpApiData

throwIfLeft :: P.Member (P.Error RestError) r => Either String a -> P.Sem r a
throwIfLeft :: forall (r :: EffectRow) a.
Member (Error RestError) r =>
Either String a -> Sem r a
throwIfLeft (Right a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
throwIfLeft (Left String
e) = forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
P.throw (Text -> RestError
InternalClientError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
e)

extractRight :: P.Member (P.Error e) r => Either e a -> P.Sem r a
extractRight :: forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
extractRight (Left e
e) = forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
P.throw e
e
extractRight (Right a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

class ReadResponse a where
  processResp :: LB.ByteString -> (Value -> Value) -> Either String a

instance {-# OVERLAPPABLE #-} FromJSON a => ReadResponse a where
  processResp :: ByteString -> (Value -> Value) -> Either String a
processResp ByteString
s Value -> Value
f = forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. (a -> Parser b) -> a -> Either String b
parseEither forall a. FromJSON a => Value -> Parser a
parseJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
f

instance ReadResponse () where
  processResp :: ByteString -> (Value -> Value) -> Either String ()
processResp ByteString
_ Value -> Value
_ = forall a b. b -> Either a b
Right ()

class Request a where
  type Result a

  route :: a -> Route

  action :: a -> Url 'Https -> Option 'Https -> Req LbsResponse

  modifyResponse :: a -> Value -> Value
  modifyResponse a
_ = forall a. a -> a
id

invoke ::
  ( P.Members '[RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r
  , Request a
  , ReadResponse (Calamity.HTTP.Internal.Request.Result a)
  ) =>
  a ->
  P.Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a))
invoke :: forall (r :: EffectRow) a.
(Members '[RatelimitEff, TokenEff, LogEff, MetricEff, Embed IO] r,
 Request a, ReadResponse (Result a)) =>
a -> Sem r (Either RestError (Result a))
invoke a
a = do
  RateLimitState
rlState' <- forall (r :: EffectRow).
Member RatelimitEff r =>
Sem r RateLimitState
getRatelimitState
  Token
token' <- forall (r :: EffectRow). Member TokenEff r => Sem r Token
getBotToken

  let route' :: Route
route' = forall a. Request a => a -> Route
route a
a

  Gauge
inFlightRequests <- forall (r :: EffectRow).
Member MetricEff r =>
Text -> [(Text, Text)] -> Sem r Gauge
registerGauge Text
"inflight_requests" [(Text
"route", forall (scheme :: Scheme). Url scheme -> Text
renderUrl forall a b. (a -> b) -> a -> b
$ Route
route' forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "path" a => a
#path)]
  Counter
totalRequests <- forall (r :: EffectRow).
Member MetricEff r =>
Text -> [(Text, Text)] -> Sem r Counter
registerCounter Text
"total_requests" [(Text
"route", forall (scheme :: Scheme). Url scheme -> Text
renderUrl forall a b. (a -> b) -> a -> b
$ Route
route' forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "path" a => a
#path)]
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow).
Member MetricEff r =>
(Double -> Double) -> Gauge -> Sem r Double
modifyGauge (forall a. Num a => a -> a -> a
+ Double
1) Gauge
inFlightRequests
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow).
Member MetricEff r =>
Int -> Counter -> Sem r Int
addCounter Int
1 Counter
totalRequests

  let r :: Req LbsResponse
r = forall a.
Request a =>
a -> Url 'Https -> Option 'Https -> Req LbsResponse
action a
a (Route
route' forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "path" a => a
#path) (Token -> Option 'Https
requestOptions Token
token')
      act :: IO LbsResponse
act = forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
reqConfig Req LbsResponse
r

  Either RestError ByteString
resp <- forall level msg (r :: EffectRow) a.
Member (Di level Path msg) r =>
Segment -> Sem r a -> Sem r a
push Segment
"calamity" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall value level msg (r :: EffectRow) a.
(ToValue value, Member (Di level Path msg) r) =>
Key -> value -> Sem r a -> Sem r a
attr Key
"route" (forall (scheme :: Scheme). Url scheme -> Text
renderUrl forall a b. (a -> b) -> a -> b
$ Route
route' forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "path" a => a
#path) forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow).
Members '[RatelimitEff, TokenEff, LogEff, Embed IO] r =>
RateLimitState
-> Route -> IO LbsResponse -> Sem r (Either RestError ByteString)
doRequest RateLimitState
rlState' Route
route' IO LbsResponse
act

  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow).
Member MetricEff r =>
(Double -> Double) -> Gauge -> Sem r Double
modifyGauge (forall a. Num a => a -> a -> a
subtract Double
1) Gauge
inFlightRequests

  forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
P.runError forall a b. (a -> b) -> a -> b
$ do
    ByteString
s <- forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
extractRight Either RestError ByteString
resp
    forall (r :: EffectRow) a.
Member (Error RestError) r =>
Either String a -> Sem r a
throwIfLeft forall a b. (a -> b) -> a -> b
$ forall a.
ReadResponse a =>
ByteString -> (Value -> Value) -> Either String a
processResp ByteString
s (forall a. Request a => a -> Value -> Value
modifyResponse a
a)

reqConfig :: HttpConfig
reqConfig :: HttpConfig
reqConfig =
  HttpConfig
defaultHttpConfig
    { httpConfigCheckResponse :: forall b.
Request -> Response b -> ByteString -> Maybe HttpExceptionContent
httpConfigCheckResponse = \Request
_ Response b
_ ByteString
_ -> forall a. Maybe a
Nothing
    }

defaultRequestOptions :: Option 'Https
defaultRequestOptions :: Option 'Https
defaultRequestOptions =
  forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"User-Agent" ByteString
"Calamity (https://github.com/simmsb/calamity)"
    forall a. Semigroup a => a -> a -> a
<> forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"X-RateLimit-Precision" ByteString
"millisecond"

requestOptions :: Token -> Option 'Https
requestOptions :: Token -> Option 'Https
requestOptions Token
t = Option 'Https
defaultRequestOptions forall a. Semigroup a => a -> a -> a
<> forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"Authorization" (Text -> ByteString
TS.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Token -> Text
formatToken Token
t)

getWith :: Url 'Https -> Option 'Https -> Req LbsResponse
getWith :: Url 'Https -> Option 'Https -> Req LbsResponse
getWith Url 'Https
u = 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
req GET
GET Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse

postWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse
postWith' :: forall a.
HttpBody a =>
a -> Url 'Https -> Option 'Https -> Req LbsResponse
postWith' a
a Url 'Https
u = 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
req POST
POST Url 'Https
u a
a Proxy LbsResponse
lbsResponse

postWithP' :: HttpBody a => a -> Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse
postWithP' :: forall a.
HttpBody a =>
a
-> Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse
postWithP' a
a Option 'Https
o Url 'Https
u Option 'Https
o' = 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
req POST
POST Url 'Https
u a
a Proxy LbsResponse
lbsResponse (Option 'Https
o forall a. Semigroup a => a -> a -> a
<> Option 'Https
o')

postEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse
postEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse
postEmpty Url 'Https
u = 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
req POST
POST Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse

putWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse
putWith' :: forall a.
HttpBody a =>
a -> Url 'Https -> Option 'Https -> Req LbsResponse
putWith' a
a Url 'Https
u = 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
req PUT
PUT Url 'Https
u a
a Proxy LbsResponse
lbsResponse

patchWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse
patchWith' :: forall a.
HttpBody a =>
a -> Url 'Https -> Option 'Https -> Req LbsResponse
patchWith' a
a Url 'Https
u = 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
req PATCH
PATCH Url 'Https
u a
a Proxy LbsResponse
lbsResponse

putEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse
putEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse
putEmpty Url 'Https
u = 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
req PUT
PUT Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse

putEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse
putEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse
putEmptyP Option 'Https
o Url 'Https
u Option 'Https
o' = 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
req PUT
PUT Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse (Option 'Https
o forall a. Semigroup a => a -> a -> a
<> Option 'Https
o')

postEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse
postEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse
postEmptyP Option 'Https
o Url 'Https
u Option 'Https
o' = 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
req POST
POST Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse (Option 'Https
o forall a. Semigroup a => a -> a -> a
<> Option 'Https
o')

getWithP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse
getWithP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse
getWithP Option 'Https
o Url 'Https
u Option 'Https
o' = 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
req GET
GET Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse (Option 'Https
o forall a. Semigroup a => a -> a -> a
<> Option 'Https
o')

deleteWith :: Url 'Https -> Option 'Https -> Req LbsResponse
deleteWith :: Url 'Https -> Option 'Https -> Req LbsResponse
deleteWith Url 'Https
u = 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
req DELETE
DELETE Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse

(=:?) :: ToHttpApiData a => T.Text -> Maybe a -> Option 'Https
Text
n =:? :: forall a. ToHttpApiData a => Text -> Maybe a -> Option 'Https
=:? (Just a
x) = Text
n forall param a.
(QueryParam param, ToHttpApiData a) =>
Text -> a -> param
=: a
x
Text
_ =:? Maybe a
Nothing = forall a. Monoid a => a
mempty