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

import Calamity.Client.Types
import Calamity.HTTP.Internal.Ratelimit
import Calamity.HTTP.Internal.Route
import Calamity.HTTP.Internal.Types
import Calamity.Metrics.Eff
import Calamity.Types.Token

import Control.Lens
import Control.Monad

import Data.Aeson hiding (Options)
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as T
import qualified Data.Text.Encoding as TS
import qualified Data.Text.Lazy as TL

import DiPolysemy hiding (debug, error, info)

import Network.HTTP.Req
import Web.HttpApiData

import Polysemy (Sem)
import qualified Polysemy as P
import qualified Polysemy.Error as P
import qualified Polysemy.Reader as P

fromResult :: P.Member (P.Error RestError) r => Data.Aeson.Result a -> Sem r a
fromResult :: Result a -> Sem r a
fromResult (Success a
a) = a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
fromResult (Error String
e) = RestError -> Sem r a
forall e (r :: [Effect]) a.
MemberWithError (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
TL.pack (String -> RestError) -> String -> RestError
forall a b. (a -> b) -> a -> b
$ String
e)

fromJSONDecode :: P.Member (P.Error RestError) r => Either String a -> Sem r a
fromJSONDecode :: Either String a -> Sem r a
fromJSONDecode (Right a
a) = a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
fromJSONDecode (Left String
e) = RestError -> Sem r a
forall e (r :: [Effect]) a.
MemberWithError (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
TL.pack (String -> RestError) -> String -> RestError
forall a b. (a -> b) -> a -> b
$ String
e)

extractRight :: P.Member (P.Error e) r => Either e a -> Sem r a
extractRight :: Either e a -> Sem r a
extractRight (Left e
e) = e -> Sem r a
forall e (r :: [Effect]) a.
MemberWithError (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
  readResp :: LB.ByteString -> Either String a

instance ReadResponse () where
  readResp :: ByteString -> Either String ()
readResp = Either String () -> ByteString -> Either String ()
forall a b. a -> b -> a
const (() -> Either String ()
forall a b. b -> Either a b
Right ())

instance {-# OVERLAPS #-} FromJSON a => ReadResponse a where
  readResp :: ByteString -> Either String a
readResp = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode

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 :: (BotC r, Request a, FromJSON (Calamity.HTTP.Internal.Request.Result a)) => a -> Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a))
invoke :: a -> Sem r (Either RestError (Result a))
invoke a
a = do
  RateLimitState
rlState' <- (Client -> RateLimitState) -> Sem r RateLimitState
forall i j (r :: [Effect]).
Member (Reader i) r =>
(i -> j) -> Sem r j
P.asks (Client
-> Getting RateLimitState Client RateLimitState -> RateLimitState
forall s a. s -> Getting a s a -> a
^. IsLabel "rlState" (Getting RateLimitState Client RateLimitState)
Getting RateLimitState Client RateLimitState
#rlState)
  Token
token' <- (Client -> Token) -> Sem r Token
forall i j (r :: [Effect]).
Member (Reader i) r =>
(i -> j) -> Sem r j
P.asks (Client -> Getting Token Client Token -> Token
forall s a. s -> Getting a s a -> a
^. IsLabel "token" (Getting Token Client Token)
Getting Token Client Token
#token)

  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 :: [Effect]).
MemberWithError 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 :: [Effect]).
MemberWithError 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 :: [Effect]).
MemberWithError 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 :: [Effect]).
MemberWithError 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 :: [Effect]) 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 :: [Effect]) 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 :: [Effect]).
BotC 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 :: [Effect]).
MemberWithError 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 :: [Effect]) 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
$ Result (Result a) -> Sem (Error RestError : r) (Result a)
forall (r :: [Effect]) a.
Member (Error RestError) r =>
Result a -> Sem r a
fromResult (Result (Result a) -> Sem (Error RestError : r) (Result a))
-> (Value -> Result (Result a))
-> Value
-> Sem (Error RestError : r) (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result (Result a)
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> Result (Result a))
-> (Value -> Value) -> Value -> Result (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value -> Value
forall a. Request a => a -> Value -> Value
modifyResponse a
a (Value -> Sem (Error RestError : r) (Result a))
-> Sem (Error RestError : r) Value
-> Sem (Error RestError : r) (Result a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either String Value -> Sem (Error RestError : r) Value
forall (r :: [Effect]) a.
Member (Error RestError) r =>
Either String a -> Sem r a
fromJSONDecode (Either String Value -> Sem (Error RestError : r) Value)
-> (ByteString -> Either String Value)
-> ByteString
-> Sem (Error RestError : r) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Value
forall a. ReadResponse a => ByteString -> Either String a
readResp (ByteString -> Sem (Error RestError : r) Value)
-> Sem (Error RestError : r) ByteString
-> Sem (Error RestError : r) Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either RestError ByteString -> Sem (Error RestError : r) ByteString
forall e (r :: [Effect]) a.
Member (Error e) r =>
Either e a -> Sem r a
extractRight Either RestError ByteString
resp

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 -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict (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
n =:? Maybe a
Nothing = Option 'Https
forall a. Monoid a => a
mempty