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

extractRight :: P.Member (P.Error e) r => Either e a -> P.Sem r a
extractRight :: Either e a -> Sem r a
extractRight (Left e
e) = e -> Sem r a
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
P.throw e
e
extractRight (Right a
a) = a -> Sem r 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 = ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
s Either String Value
-> (Value -> Either String a) -> Either String a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Either String a)
-> (Value -> Value) -> Value -> Either String a
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
_ = () -> Either String ()
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
_ = Value -> Value
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 :: a -> Sem r (Either RestError (Result a))
invoke a
a = do
  RateLimitState
rlState' <- Sem r RateLimitState
forall (r :: EffectRow).
Member RatelimitEff r =>
Sem r RateLimitState
getRatelimitState
  Token
token' <- Sem r Token
forall (r :: EffectRow). Member TokenEff r => Sem r Token
getBotToken

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

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

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

  Either RestError ByteString
resp <- Segment
-> Sem r (Either RestError ByteString)
-> Sem r (Either RestError ByteString)
forall level msg (r :: EffectRow) a.
Member (Di level Path msg) r =>
Segment -> Sem r a -> Sem r a
push Segment
"calamity" (Sem r (Either RestError ByteString)
 -> Sem r (Either RestError ByteString))
-> (Sem r (Either RestError ByteString)
    -> Sem r (Either RestError ByteString))
-> Sem r (Either RestError ByteString)
-> Sem r (Either RestError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key
-> Text
-> Sem r (Either RestError ByteString)
-> Sem r (Either RestError ByteString)
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" (Url 'Https -> Text
forall (scheme :: Scheme). Url scheme -> Text
renderUrl (Url 'Https -> Text) -> Url 'Https -> Text
forall a b. (a -> b) -> a -> b
$ Route
route' Route -> Getting (Url 'Https) Route (Url 'Https) -> Url 'Https
forall s a. s -> Getting a s a -> a
^. IsLabel "path" (Getting (Url 'Https) Route (Url 'Https))
Getting (Url 'Https) Route (Url 'Https)
#path) (Sem r (Either RestError ByteString)
 -> Sem r (Either RestError ByteString))
-> Sem r (Either RestError ByteString)
-> Sem r (Either RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RateLimitState
-> Route -> IO LbsResponse -> Sem r (Either RestError ByteString)
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

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

  Sem (Error RestError : r) (Result a)
-> Sem r (Either RestError (Result a))
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
P.runError (Sem (Error RestError : r) (Result a)
 -> Sem r (Either RestError (Result a)))
-> Sem (Error RestError : r) (Result a)
-> Sem r (Either RestError (Result a))
forall a b. (a -> b) -> a -> b
$ do
    ByteString
s <- Either RestError ByteString -> Sem (Error RestError : r) ByteString
forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
extractRight Either RestError ByteString
resp
    Either String (Result a) -> Sem (Error RestError : r) (Result a)
forall (r :: EffectRow) a.
Member (Error RestError) r =>
Either String a -> Sem r a
throwIfLeft (Either String (Result a) -> Sem (Error RestError : r) (Result a))
-> Either String (Result a) -> Sem (Error RestError : r) (Result a)
forall a b. (a -> b) -> a -> b
$ ByteString -> (Value -> Value) -> Either String (Result a)
forall a.
ReadResponse a =>
ByteString -> (Value -> Value) -> Either String a
processResp ByteString
s (a -> Value -> Value
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
_ -> Maybe HttpExceptionContent
forall a. Maybe a
Nothing
    }

defaultRequestOptions :: Option 'Https
defaultRequestOptions :: Option 'Https
defaultRequestOptions =
  ByteString -> ByteString -> Option 'Https
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"User-Agent" ByteString
"Calamity (https://github.com/simmsb/calamity)"
    Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> Option 'Https
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 Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> Option 'Https
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"Authorization" (Text -> ByteString
TS.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
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 = GET
-> Url 'Https
-> NoReqBody
-> Proxy LbsResponse
-> Option 'Https
-> Req 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
req GET
GET Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse

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

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

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

patchWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse
patchWith' :: a -> Url 'Https -> Option 'Https -> Req LbsResponse
patchWith' a
a Url 'Https
u = PATCH
-> Url 'Https
-> a
-> Proxy LbsResponse
-> Option 'Https
-> Req 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
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 = PUT
-> Url 'Https
-> NoReqBody
-> Proxy LbsResponse
-> Option 'Https
-> Req 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
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' = PUT
-> Url 'Https
-> NoReqBody
-> Proxy LbsResponse
-> Option 'Https
-> Req 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
req PUT
PUT Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse (Option 'Https
o Option 'Https -> Option 'Https -> Option 'Https
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' = POST
-> Url 'Https
-> NoReqBody
-> Proxy LbsResponse
-> Option 'Https
-> Req 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
req POST
POST Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse (Option 'Https
o Option 'Https -> Option 'Https -> Option 'Https
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' = GET
-> Url 'Https
-> NoReqBody
-> Proxy LbsResponse
-> Option 'Https
-> Req 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
req GET
GET Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse (Option 'Https
o Option 'Https -> Option 'Https -> Option 'Https
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 = DELETE
-> Url 'Https
-> NoReqBody
-> Proxy LbsResponse
-> Option 'Https
-> Req 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
req DELETE
DELETE Url 'Https
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse

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