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
(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