{-# LANGUAGE FlexibleContexts #-}

-- | Module implementing various OAuth2 flow types and their request/response handling.
-- Provides support for:
--
--   * Authorization Code Grant
--   * Device Authorization Grant
--   * PKCE Extension
--   * Token Refresh
--   * User Info Endpoints
module Network.OAuth2.Experiment.Flows where

import Control.Concurrent
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Except
import Data.Aeson (FromJSON)
import Data.Bifunctor
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.Map.Strict qualified as Map
import Data.Maybe
import Network.HTTP.Client.Contrib
import Network.HTTP.Conduit
import Network.OAuth2
import Network.OAuth2 qualified as OAuth2
import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest
import Network.OAuth2.Experiment.Flows.RefreshTokenRequest
import Network.OAuth2.Experiment.Flows.TokenRequest
import Network.OAuth2.Experiment.Flows.UserInfoRequest
import Network.OAuth2.Experiment.Grants.AuthorizationCode
import Network.OAuth2.Experiment.Grants.DeviceAuthorization
import Network.OAuth2.Experiment.Pkce
import Network.OAuth2.Experiment.Types
import Network.OAuth2.Experiment.Utils
import URI.ByteString hiding (UserInfo)

-------------------------------------------------------------------------------
--                           Authorization Requests                          --
-------------------------------------------------------------------------------

-- | Constructs an Authorization Code request URI according to
-- <https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 RFC 6749 Section 4.1.1>.
--
-- The generated URI includes:
--   * client_id
--   * response_type (always "code")
--   * redirect_uri
--   * state (if provided)
--   * scope (if provided)
mkAuthorizationRequest :: IdpApplication i AuthorizationCodeApplication -> URI
mkAuthorizationRequest :: forall {k} (i :: k).
IdpApplication i AuthorizationCodeApplication -> URI
mkAuthorizationRequest IdpApplication i AuthorizationCodeApplication
idpApp =
  let req :: AuthorizationRequestParam
req = AuthorizationCodeApplication -> AuthorizationRequestParam
mkAuthorizationRequestParam (IdpApplication i AuthorizationCodeApplication
-> AuthorizationCodeApplication
forall k (i :: k) a. IdpApplication i a -> a
application IdpApplication i AuthorizationCodeApplication
idpApp)
      allParams :: [(ByteString, ByteString)]
allParams =
        ((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> ByteString
tlToBS Text -> ByteString
tlToBS) ([(Text, Text)] -> [(ByteString, ByteString)])
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$
          Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$
            AuthorizationRequestParam -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam AuthorizationRequestParam
req
   in [(ByteString, ByteString)] -> URI -> URI
forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString, ByteString)]
allParams (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$
        Idp i -> URI
forall k (i :: k). Idp i -> URI
idpAuthorizeEndpoint (IdpApplication i AuthorizationCodeApplication -> Idp i
forall k (i :: k) a. IdpApplication i a -> Idp i
idp IdpApplication i AuthorizationCodeApplication
idpApp)

-- | Constructs an Authorization Code request URI with PKCE support according to
-- <https://datatracker.ietf.org/doc/html/rfc7636 RFC 7636>.
--
-- Returns both the authorization URI and the generated code verifier.
-- The code verifier must be stored securely for later use in the token request.
mkPkceAuthorizeRequest ::
  MonadIO m =>
  IdpApplication i AuthorizationCodeApplication ->
  m (URI, CodeVerifier)
mkPkceAuthorizeRequest :: forall {k} (m :: * -> *) (i :: k).
MonadIO m =>
IdpApplication i AuthorizationCodeApplication
-> m (URI, CodeVerifier)
mkPkceAuthorizeRequest IdpApplication {Idp i
AuthorizationCodeApplication
application :: forall k (i :: k) a. IdpApplication i a -> a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
idp :: Idp i
application :: AuthorizationCodeApplication
..} = do
  (AuthorizationRequestParam
req, CodeVerifier
codeVerifier) <- AuthorizationCodeApplication
-> m (AuthorizationRequestParam, CodeVerifier)
forall (m :: * -> *).
MonadIO m =>
AuthorizationCodeApplication
-> m (AuthorizationRequestParam, CodeVerifier)
mkPkceAuthorizeRequestParam AuthorizationCodeApplication
application
  let allParams :: [(ByteString, ByteString)]
allParams = ((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> ByteString
tlToBS Text -> ByteString
tlToBS) ([(Text, Text)] -> [(ByteString, ByteString)])
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ AuthorizationRequestParam -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam AuthorizationRequestParam
req
  let url :: URI
url =
        [(ByteString, ByteString)] -> URI -> URI
forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString, ByteString)]
allParams (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$
          Idp i -> URI
forall k (i :: k). Idp i -> URI
idpAuthorizeEndpoint Idp i
idp
  (URI, CodeVerifier) -> m (URI, CodeVerifier)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI
url, CodeVerifier
codeVerifier)

-------------------------------------------------------------------------------
--                                Device Auth                                --
-------------------------------------------------------------------------------

-- | Makes Device Authorization Request
-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1
conduitDeviceAuthorizationRequest ::
  MonadIO m =>
  IdpApplication i DeviceAuthorizationApplication ->
  Manager ->
  ExceptT BSL.ByteString m DeviceAuthorizationResponse
conduitDeviceAuthorizationRequest :: forall {k} (m :: * -> *) (i :: k).
MonadIO m =>
IdpApplication i DeviceAuthorizationApplication
-> Manager -> ExceptT ByteString m DeviceAuthorizationResponse
conduitDeviceAuthorizationRequest IdpApplication {Idp i
DeviceAuthorizationApplication
application :: forall k (i :: k) a. IdpApplication i a -> a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
idp :: Idp i
application :: DeviceAuthorizationApplication
..} Manager
mgr = do
  case Idp i -> Maybe URI
forall k (i :: k). Idp i -> Maybe URI
idpDeviceAuthorizationEndpoint Idp i
idp of
    Maybe URI
Nothing -> ByteString -> ExceptT ByteString m DeviceAuthorizationResponse
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ByteString
"[conduitDeviceAuthorizationRequest] Device Authorization Flow is not supported: missing device_authorization_endpoint."
    Just URI
deviceAuthEndpoint -> do
      let deviceAuthReq :: DeviceAuthorizationRequestParam
deviceAuthReq = DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam
mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication
application
          body :: [(ByteString, ByteString)]
body = [Map Text Text] -> [(ByteString, ByteString)]
unionMapsToQueryParams [DeviceAuthorizationRequestParam -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam DeviceAuthorizationRequestParam
deviceAuthReq]
      m (Either ByteString DeviceAuthorizationResponse)
-> ExceptT ByteString m DeviceAuthorizationResponse
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ByteString DeviceAuthorizationResponse)
 -> ExceptT ByteString m DeviceAuthorizationResponse)
-> (IO (Either ByteString DeviceAuthorizationResponse)
    -> m (Either ByteString DeviceAuthorizationResponse))
-> IO (Either ByteString DeviceAuthorizationResponse)
-> ExceptT ByteString m DeviceAuthorizationResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ByteString DeviceAuthorizationResponse)
-> m (Either ByteString DeviceAuthorizationResponse)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ByteString DeviceAuthorizationResponse)
 -> ExceptT ByteString m DeviceAuthorizationResponse)
-> IO (Either ByteString DeviceAuthorizationResponse)
-> ExceptT ByteString m DeviceAuthorizationResponse
forall a b. (a -> b) -> a -> b
$ do
        Request
req <- Request -> Request
addDefaultRequestHeaders (Request -> Request) -> IO Request -> IO Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
deviceAuthEndpoint
        let req' :: Request
req' =
              if DeviceAuthorizationApplication -> ClientAuthenticationMethod
daAuthorizationRequestAuthenticationMethod DeviceAuthorizationApplication
application ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== ClientAuthenticationMethod
ClientSecretBasic
                then ClientId -> ClientSecret -> Request -> Request
addSecretToHeader (DeviceAuthorizationApplication -> ClientId
daClientId DeviceAuthorizationApplication
application) (DeviceAuthorizationApplication -> ClientSecret
daClientSecret DeviceAuthorizationApplication
application) Request
req
                else Request
req
        Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs ([(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
body Request
req') Manager
mgr
        Either ByteString DeviceAuthorizationResponse
-> IO (Either ByteString DeviceAuthorizationResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ByteString DeviceAuthorizationResponse
 -> IO (Either ByteString DeviceAuthorizationResponse))
-> Either ByteString DeviceAuthorizationResponse
-> IO (Either ByteString DeviceAuthorizationResponse)
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString)
-> Either ByteString DeviceAuthorizationResponse
-> Either ByteString DeviceAuthorizationResponse
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString
"[conduitDeviceAuthorizationRequest] " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (Either ByteString DeviceAuthorizationResponse
 -> Either ByteString DeviceAuthorizationResponse)
-> Either ByteString DeviceAuthorizationResponse
-> Either ByteString DeviceAuthorizationResponse
forall a b. (a -> b) -> a -> b
$ Response ByteString
-> Either ByteString DeviceAuthorizationResponse
forall a. FromJSON a => Response ByteString -> Either ByteString a
handleResponseJSON Response ByteString
resp

-- | Polls for a token using the device authorization flow.
--
-- This implements the polling mechanism described in
-- <https://www.rfc-editor.org/rfc/rfc8628#section-3.5 RFC 8628 Section 3.5>.
-- Handles automatic retries and interval adjustments based on IdP responses.
pollDeviceTokenRequest ::
  MonadIO m =>
  IdpApplication i DeviceAuthorizationApplication ->
  Manager ->
  DeviceAuthorizationResponse ->
  ExceptT TokenResponseError m TokenResponse
pollDeviceTokenRequest :: forall {k} (m :: * -> *) (i :: k).
MonadIO m =>
IdpApplication i DeviceAuthorizationApplication
-> Manager
-> DeviceAuthorizationResponse
-> ExceptT TokenResponseError m TokenResponse
pollDeviceTokenRequest IdpApplication i DeviceAuthorizationApplication
idpApp Manager
mgr DeviceAuthorizationResponse
deviceAuthResp = do
  IdpApplication i DeviceAuthorizationApplication
-> Manager
-> DeviceCode
-> Int
-> ExceptT TokenResponseError m TokenResponse
forall {k} (m :: * -> *) (i :: k).
MonadIO m =>
IdpApplication i DeviceAuthorizationApplication
-> Manager
-> DeviceCode
-> Int
-> ExceptT TokenResponseError m TokenResponse
pollDeviceTokenRequestInternal
    IdpApplication i DeviceAuthorizationApplication
idpApp
    Manager
mgr
    (DeviceAuthorizationResponse -> DeviceCode
deviceCode DeviceAuthorizationResponse
deviceAuthResp)
    (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
5 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ DeviceAuthorizationResponse -> Maybe Int
interval DeviceAuthorizationResponse
deviceAuthResp)

pollDeviceTokenRequestInternal ::
  MonadIO m =>
  IdpApplication i DeviceAuthorizationApplication ->
  Manager ->
  DeviceCode ->
  Int ->
  -- | Polling Interval
  ExceptT TokenResponseError m TokenResponse
pollDeviceTokenRequestInternal :: forall {k} (m :: * -> *) (i :: k).
MonadIO m =>
IdpApplication i DeviceAuthorizationApplication
-> Manager
-> DeviceCode
-> Int
-> ExceptT TokenResponseError m TokenResponse
pollDeviceTokenRequestInternal IdpApplication i DeviceAuthorizationApplication
idpApp Manager
mgr DeviceCode
deviceCode Int
intervalSeconds = do
  Either TokenResponseError TokenResponse
resp <- ExceptT
  TokenResponseError (ExceptT TokenResponseError m) TokenResponse
-> ExceptT
     TokenResponseError m (Either TokenResponseError TokenResponse)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (IdpApplication i DeviceAuthorizationApplication
-> Manager
-> ExchangeTokenInfo DeviceAuthorizationApplication
-> ExceptT
     TokenResponseError (ExceptT TokenResponseError m) TokenResponse
forall {k} a (m :: * -> *) (i :: k).
(HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
IdpApplication i a
-> Manager
-> ExchangeTokenInfo a
-> ExceptT TokenResponseError m TokenResponse
conduitTokenRequest IdpApplication i DeviceAuthorizationApplication
idpApp Manager
mgr DeviceCode
ExchangeTokenInfo DeviceAuthorizationApplication
deviceCode)
  case Either TokenResponseError TokenResponse
resp of
    Left TokenResponseError
trRespError -> do
      case TokenResponseError -> TokenResponseErrorCode
tokenResponseError TokenResponseError
trRespError of
        -- TODO: Didn't have a good idea to expand the error code
        -- specifically for device token request flow
        -- Device Token Response additional error code: https://www.rfc-editor.org/rfc/rfc8628#section-3.5
        UnknownErrorCode Text
"authorization_pending" -> do
          IO () -> ExceptT TokenResponseError m ()
forall a. IO a -> ExceptT TokenResponseError m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT TokenResponseError m ())
-> IO () -> ExceptT TokenResponseError m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
intervalSeconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
          IdpApplication i DeviceAuthorizationApplication
-> Manager
-> DeviceCode
-> Int
-> ExceptT TokenResponseError m TokenResponse
forall {k} (m :: * -> *) (i :: k).
MonadIO m =>
IdpApplication i DeviceAuthorizationApplication
-> Manager
-> DeviceCode
-> Int
-> ExceptT TokenResponseError m TokenResponse
pollDeviceTokenRequestInternal IdpApplication i DeviceAuthorizationApplication
idpApp Manager
mgr DeviceCode
deviceCode Int
intervalSeconds
        UnknownErrorCode Text
"slow_down" -> do
          let newIntervalSeconds :: Int
newIntervalSeconds = Int
intervalSeconds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5
          IO () -> ExceptT TokenResponseError m ()
forall a. IO a -> ExceptT TokenResponseError m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT TokenResponseError m ())
-> IO () -> ExceptT TokenResponseError m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
newIntervalSeconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
          IdpApplication i DeviceAuthorizationApplication
-> Manager
-> DeviceCode
-> Int
-> ExceptT TokenResponseError m TokenResponse
forall {k} (m :: * -> *) (i :: k).
MonadIO m =>
IdpApplication i DeviceAuthorizationApplication
-> Manager
-> DeviceCode
-> Int
-> ExceptT TokenResponseError m TokenResponse
pollDeviceTokenRequestInternal IdpApplication i DeviceAuthorizationApplication
idpApp Manager
mgr DeviceCode
deviceCode Int
newIntervalSeconds
        TokenResponseErrorCode
_ -> TokenResponseError -> ExceptT TokenResponseError m TokenResponse
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TokenResponseError
trRespError
    Right TokenResponse
v -> TokenResponse -> ExceptT TokenResponseError m TokenResponse
forall a. a -> ExceptT TokenResponseError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TokenResponse
v

-------------------------------------------------------------------------------
--                               Token Request                               --
-------------------------------------------------------------------------------

-- | Sends a token request according to
-- <https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 RFC 6749 Section 4.1.3>.
--
-- This is used for exchanging authorization codes, device codes, or other
-- grant types for access tokens.
conduitTokenRequest ::
  (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
  IdpApplication i a ->
  Manager ->
  ExchangeTokenInfo a ->
  ExceptT TokenResponseError m TokenResponse
conduitTokenRequest :: forall {k} a (m :: * -> *) (i :: k).
(HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
IdpApplication i a
-> Manager
-> ExchangeTokenInfo a
-> ExceptT TokenResponseError m TokenResponse
conduitTokenRequest IdpApplication i a
idpApp Manager
mgr ExchangeTokenInfo a
exchangeToken = do
  let req :: TokenRequest a
req = a -> ExchangeTokenInfo a -> TokenRequest a
forall a.
HasTokenRequest a =>
a -> ExchangeTokenInfo a -> TokenRequest a
mkTokenRequestParam (IdpApplication i a -> a
forall k (i :: k) a. IdpApplication i a -> a
application IdpApplication i a
idpApp) ExchangeTokenInfo a
exchangeToken
      body :: [(ByteString, ByteString)]
body =
        [Map Text Text] -> [(ByteString, ByteString)]
unionMapsToQueryParams
          [ TokenRequest a -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam TokenRequest a
req
          ]
   in IdpApplication i a
-> Manager
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m TokenResponse
forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasClientAuthenticationMethod a, FromJSON b) =>
IdpApplication i a
-> Manager
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m b
conduitTokenRequestInternal IdpApplication i a
idpApp Manager
mgr [(ByteString, ByteString)]
body

-------------------------------------------------------------------------------
--                             PKCE Token Request                            --
-------------------------------------------------------------------------------

-- | https://datatracker.ietf.org/doc/html/rfc7636#section-4.5
conduitPkceTokenRequest ::
  (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
  IdpApplication i a ->
  Manager ->
  (ExchangeTokenInfo a, CodeVerifier) ->
  ExceptT TokenResponseError m TokenResponse
conduitPkceTokenRequest :: forall {k} a (m :: * -> *) (i :: k).
(HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
IdpApplication i a
-> Manager
-> (ExchangeTokenInfo a, CodeVerifier)
-> ExceptT TokenResponseError m TokenResponse
conduitPkceTokenRequest IdpApplication i a
idpApp Manager
mgr (ExchangeTokenInfo a
exchangeToken, CodeVerifier
codeVerifier) =
  let req :: TokenRequest a
req = a -> ExchangeTokenInfo a -> TokenRequest a
forall a.
HasTokenRequest a =>
a -> ExchangeTokenInfo a -> TokenRequest a
mkTokenRequestParam (IdpApplication i a -> a
forall k (i :: k) a. IdpApplication i a -> a
application IdpApplication i a
idpApp) ExchangeTokenInfo a
exchangeToken
      body :: [(ByteString, ByteString)]
body =
        [Map Text Text] -> [(ByteString, ByteString)]
unionMapsToQueryParams
          [ TokenRequest a -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam TokenRequest a
req
          , CodeVerifier -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam CodeVerifier
codeVerifier
          ]
   in IdpApplication i a
-> Manager
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m TokenResponse
forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasClientAuthenticationMethod a, FromJSON b) =>
IdpApplication i a
-> Manager
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m b
conduitTokenRequestInternal IdpApplication i a
idpApp Manager
mgr [(ByteString, ByteString)]
body

-------------------------------------------------------------------------------
--                              Refresh Token                               --
-------------------------------------------------------------------------------

-- | Makes a Refresh Token Request according to
-- <https://www.rfc-editor.org/rfc/rfc6749#section-6 RFC 6749 Section 6>.
--
-- Used to obtain a new access token using a refresh token.
conduitRefreshTokenRequest ::
  (MonadIO m, HasRefreshTokenRequest a) =>
  IdpApplication i a ->
  Manager ->
  OAuth2.RefreshToken ->
  ExceptT TokenResponseError m TokenResponse
conduitRefreshTokenRequest :: forall {k} (m :: * -> *) a (i :: k).
(MonadIO m, HasRefreshTokenRequest a) =>
IdpApplication i a
-> Manager
-> RefreshToken
-> ExceptT TokenResponseError m TokenResponse
conduitRefreshTokenRequest IdpApplication i a
ia Manager
mgr RefreshToken
rt =
  let tokenReq :: RefreshTokenRequest
tokenReq = a -> RefreshToken -> RefreshTokenRequest
forall a.
HasRefreshTokenRequest a =>
a -> RefreshToken -> RefreshTokenRequest
mkRefreshTokenRequestParam (IdpApplication i a -> a
forall k (i :: k) a. IdpApplication i a -> a
application IdpApplication i a
ia) RefreshToken
rt
      body :: [(ByteString, ByteString)]
body = [Map Text Text] -> [(ByteString, ByteString)]
unionMapsToQueryParams [RefreshTokenRequest -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam RefreshTokenRequest
tokenReq]
   in IdpApplication i a
-> Manager
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m TokenResponse
forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasClientAuthenticationMethod a, FromJSON b) =>
IdpApplication i a
-> Manager
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m b
conduitTokenRequestInternal IdpApplication i a
ia Manager
mgr [(ByteString, ByteString)]
body

-------------------------------------------------------------------------------
--                                 User Info                                 --
-------------------------------------------------------------------------------

-- | Makes a standard request to the userinfo endpoint using GET method.
--
-- This is commonly used with OpenID Connect providers to fetch
-- user profile information using an access token.
conduitUserInfoRequest ::
  (MonadIO m, HasUserInfoRequest a, FromJSON b) =>
  IdpApplication i a ->
  Manager ->
  AccessToken ->
  ExceptT BSL.ByteString m b
conduitUserInfoRequest :: forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasUserInfoRequest a, FromJSON b) =>
IdpApplication i a
-> Manager -> AccessToken -> ExceptT ByteString m b
conduitUserInfoRequest = (Manager -> AccessToken -> URI -> ExceptT ByteString m b)
-> IdpApplication i a
-> Manager
-> AccessToken
-> ExceptT ByteString m b
forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasUserInfoRequest a, FromJSON b) =>
(Manager -> AccessToken -> URI -> ExceptT ByteString m b)
-> IdpApplication i a
-> Manager
-> AccessToken
-> ExceptT ByteString m b
conduitUserInfoRequestWithCustomMethod Manager -> AccessToken -> URI -> ExceptT ByteString m b
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager -> AccessToken -> URI -> ExceptT ByteString m a
authGetJSON

-- | Makes a request to the userinfo endpoint using a custom HTTP method.
--
-- Some IdPs may require different HTTP methods (instead of GET) or custom headers
-- for fetching user information. This function provides that flexibility.
conduitUserInfoRequestWithCustomMethod ::
  (MonadIO m, HasUserInfoRequest a, FromJSON b) =>
  ( Manager ->
    AccessToken ->
    URI ->
    ExceptT BSL.ByteString m b
  ) ->
  IdpApplication i a ->
  Manager ->
  AccessToken ->
  ExceptT BSL.ByteString m b
conduitUserInfoRequestWithCustomMethod :: forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasUserInfoRequest a, FromJSON b) =>
(Manager -> AccessToken -> URI -> ExceptT ByteString m b)
-> IdpApplication i a
-> Manager
-> AccessToken
-> ExceptT ByteString m b
conduitUserInfoRequestWithCustomMethod Manager -> AccessToken -> URI -> ExceptT ByteString m b
fetchMethod IdpApplication {a
Idp i
application :: forall k (i :: k) a. IdpApplication i a -> a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
idp :: Idp i
application :: a
..} Manager
mgr AccessToken
at =
  Manager -> AccessToken -> URI -> ExceptT ByteString m b
fetchMethod Manager
mgr AccessToken
at (Idp i -> URI
forall k (i :: k). Idp i -> URI
idpUserInfoEndpoint Idp i
idp)

-------------------------------------------------------------------------------
--                              Internal helpers                             --
-------------------------------------------------------------------------------

conduitTokenRequestInternal ::
  ( MonadIO m
  , HasClientAuthenticationMethod a
  , FromJSON b
  ) =>
  IdpApplication i a ->
  -- | HTTP connection manager.
  Manager ->
  -- | Request body.
  PostBody ->
  -- | Response as ByteString
  ExceptT TokenResponseError m b
conduitTokenRequestInternal :: forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasClientAuthenticationMethod a, FromJSON b) =>
IdpApplication i a
-> Manager
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m b
conduitTokenRequestInternal IdpApplication {a
Idp i
application :: forall k (i :: k) a. IdpApplication i a -> a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
idp :: Idp i
application :: a
..} Manager
manager [(ByteString, ByteString)]
body = do
  let clientAuthMethod :: ClientAuthenticationMethod
clientAuthMethod = a -> ClientAuthenticationMethod
forall a.
HasClientAuthenticationMethod a =>
a -> ClientAuthenticationMethod
getClientAuthenticationMethod a
application
      url :: URI
url = Idp i -> URI
forall k (i :: k). Idp i -> URI
idpTokenEndpoint Idp i
idp
      updateAuthHeader :: Request -> Request
updateAuthHeader =
        case ClientAuthenticationMethod
clientAuthMethod of
          ClientAuthenticationMethod
ClientSecretBasic -> a -> Request -> Request
forall a.
HasClientAuthenticationMethod a =>
a -> Request -> Request
addClientAuthToHeader a
application
          ClientAuthenticationMethod
ClientSecretPost -> Request -> Request
forall a. a -> a
id
          ClientAuthenticationMethod
ClientAssertionJwt -> Request -> Request
forall a. a -> a
id
      go :: IO (Response ByteString)
go = do
        Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
        let req' :: Request
req' = (Request -> Request
updateAuthHeader (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
addDefaultRequestHeaders) Request
req
        Request -> Manager -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs ([(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
body Request
req') Manager
manager
  ByteString
resp <- m (Either TokenResponseError ByteString)
-> ExceptT TokenResponseError m ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either TokenResponseError ByteString)
 -> ExceptT TokenResponseError m ByteString)
-> (IO (Either TokenResponseError ByteString)
    -> m (Either TokenResponseError ByteString))
-> IO (Either TokenResponseError ByteString)
-> ExceptT TokenResponseError m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either TokenResponseError ByteString)
-> m (Either TokenResponseError ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either TokenResponseError ByteString)
 -> ExceptT TokenResponseError m ByteString)
-> IO (Either TokenResponseError ByteString)
-> ExceptT TokenResponseError m ByteString
forall a b. (a -> b) -> a -> b
$ (Response ByteString -> Either TokenResponseError ByteString)
-> IO (Response ByteString)
-> IO (Either TokenResponseError ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response ByteString -> Either TokenResponseError ByteString
handleOAuth2TokenResponse IO (Response ByteString)
go
  case ByteString -> Either TokenResponseError b
forall a. FromJSON a => ByteString -> Either TokenResponseError a
parseResponseFlexible ByteString
resp of
    Right b
obj -> b -> ExceptT TokenResponseError m b
forall a. a -> ExceptT TokenResponseError m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
obj
    Left TokenResponseError
e -> TokenResponseError -> ExceptT TokenResponseError m b
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TokenResponseError
e