{-# 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 -- TODO: Error handling
                                                        Right RefreshTokenResponse
x -> RefreshTokenResponse
x
    UpdateTokenPair
u TokenPair
newTokenPair
    TokenPair -> IO TokenPair
forall (m :: * -> *) a. Monad m => a -> m a
return TokenPair
newTokenPair