{-# LANGUAGE DataKinds #-}
module Network.HTTP.Req.OAuth2.Internal.Verbs
( oAuth2Get
) where
import Control.Exception (catch, throwIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State.Strict (get, put)
import Data.Aeson (Value)
import Data.Aeson.Types (Parser, parseEither)
import Network.HTTP.Req
( GET(..)
, NoReqBody(..)
, Scheme(..)
, Url
, defaultHttpConfig
, jsonResponse
, req
, responseBody
, runReq
)
import Network.HTTP.Req.OAuth2.Internal.RefreshToken
import Network.HTTP.Req.OAuth2.Internal.Types
import Network.HTTP.Req.OAuth2.Internal.Util
import Network.HTTP.Types (unauthorized401)
oAuth2Get ::
(Value -> Parser a)
-> Url 'Https
-> App
-> OAuth2 a
oAuth2Get :: (Value -> Parser a) -> Url 'Https -> App -> OAuth2 a
oAuth2Get Value -> Parser a
p Url 'Https
apiUrl App
app = do
tokenPair :: TokenPair
tokenPair@(TokenPair AccessToken
accessToken RefreshToken
_) <- StateT TokenPair IO TokenPair
forall (m :: * -> *) s. Monad m => StateT s m s
get
(Value
value, TokenPair
tokenPair') <-
IO (Value, TokenPair) -> StateT TokenPair IO (Value, TokenPair)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Value, TokenPair) -> StateT TokenPair IO (Value, TokenPair))
-> IO (Value, TokenPair) -> StateT TokenPair IO (Value, TokenPair)
forall a b. (a -> b) -> a -> b
$ IO (Value, TokenPair)
-> (HttpException -> IO (Value, TokenPair))
-> IO (Value, TokenPair)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(Url 'Https -> AccessToken -> IO Value
getHelper Url 'Https
apiUrl AccessToken
accessToken IO Value
-> (Value -> IO (Value, TokenPair)) -> IO (Value, TokenPair)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value
value -> (Value, TokenPair) -> IO (Value, TokenPair)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
value, TokenPair
tokenPair)) ((HttpException -> IO (Value, TokenPair)) -> IO (Value, TokenPair))
-> (HttpException -> IO (Value, TokenPair))
-> IO (Value, TokenPair)
forall a b. (a -> b) -> a -> b
$ \HttpException
e ->
if HttpException -> Status -> Bool
hasResponseStatus HttpException
e Status
unauthorized401
then do
newTokenPair :: TokenPair
newTokenPair@(TokenPair AccessToken
newAccessToken RefreshToken
_) <- App -> TokenPair -> IO TokenPair
refreshHelper App
app TokenPair
tokenPair
Value
result <- Url 'Https -> AccessToken -> IO Value
getHelper Url 'Https
apiUrl AccessToken
newAccessToken
(Value, TokenPair) -> IO (Value, TokenPair)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
result, TokenPair
newTokenPair)
else HttpException -> IO (Value, TokenPair)
forall e a. Exception e => e -> IO a
throwIO HttpException
e
TokenPair -> StateT TokenPair IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put TokenPair
tokenPair'
case (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser a
p Value
value of
Left String
e -> IO a -> OAuth2 a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ParseError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ParseError -> IO a) -> ParseError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError String
e)
Right a
result -> a -> OAuth2 a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
getHelper ::
Url 'Https
-> AccessToken
-> IO Value
getHelper :: Url 'Https -> AccessToken -> IO Value
getHelper Url 'Https
url AccessToken
accessToken =
JsonResponse Value -> Value
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody (JsonResponse Value -> Value)
-> IO (JsonResponse Value) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HttpConfig -> Req (JsonResponse Value) -> IO (JsonResponse Value)
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req (JsonResponse Value) -> IO (JsonResponse Value))
-> Req (JsonResponse Value) -> IO (JsonResponse Value)
forall a b. (a -> b) -> a -> b
$ GET
-> Url 'Https
-> NoReqBody
-> Proxy (JsonResponse Value)
-> Option 'Https
-> Req (JsonResponse Value)
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
url NoReqBody
NoReqBody Proxy (JsonResponse Value)
forall a. Proxy (JsonResponse a)
jsonResponse (AccessToken -> Option 'Https
oAuth2BearerHeader AccessToken
accessToken Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> Option 'Https
forall (scheme :: Scheme). Option scheme
acceptLanguage))
refreshHelper ::
App
-> TokenPair
-> IO TokenPair
refreshHelper :: App -> TokenPair -> IO TokenPair
refreshHelper app :: App
app@(App URI
_ URI
_ UpdateTokenPair
u ClientPair
_) (TokenPair AccessToken
_ RefreshToken
refreshToken) = do
Either String RefreshTokenResponse
result <- App
-> RefreshTokenRequest -> IO (Either String RefreshTokenResponse)
fetchRefreshToken App
app (RefreshToken -> RefreshTokenRequest
RefreshTokenRequest RefreshToken
refreshToken)
let (RefreshTokenResponse TokenPair
newTokenPair) = case Either String RefreshTokenResponse
result of
Left String
e -> String -> RefreshTokenResponse
forall a. HasCallStack => String -> a
error String
e
Right RefreshTokenResponse
x -> RefreshTokenResponse
x
UpdateTokenPair
u TokenPair
newTokenPair
TokenPair -> IO TokenPair
forall (m :: * -> *) a. Monad m => a -> m a
return TokenPair
newTokenPair