{-# LANGUAGE FlexibleContexts #-}

module Network.OAuth2.Experiment.Flows.TokenRequest where

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Except (ExceptT (..), throwE)
import Network.HTTP.Conduit
import Network.OAuth.OAuth2 hiding (RefreshToken)
import Network.OAuth2.Experiment.Pkce
import Network.OAuth2.Experiment.Types
import Network.OAuth2.Experiment.Utils

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

class HasTokenRequestClientAuthenticationMethod a where
  getClientAuthenticationMethod :: a -> ClientAuthenticationMethod

-- | Only Authorization Code Grant involves a Exchange Token (Authorization Code).
-- ResourceOwnerPassword and Client Credentials make token request directly.
data NoNeedExchangeToken = NoNeedExchangeToken

class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasTokenRequest a where
  -- Each GrantTypeFlow has slightly different request parameter to /token endpoint.
  data TokenRequest a
  type ExchangeTokenInfo a

  -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request
  -- create type family to be explicit on it.
  -- with 'type instance WithExchangeToken a b = b' implies no exchange token
  -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token
  -- type WithExchangeToken a b
  mkTokenRequestParam :: a -> ExchangeTokenInfo a -> TokenRequest a

-- | Make Token Request
-- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3
conduitTokenRequest ::
  (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
  IdpApplication i a ->
  Manager ->
  ExchangeTokenInfo a ->
  ExceptT TokenResponseError m OAuth2Token
conduitTokenRequest :: forall {k} a (m :: * -> *) (i :: k).
(HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
IdpApplication i a
-> Manager
-> ExchangeTokenInfo a
-> ExceptT TokenResponseError m OAuth2Token
conduitTokenRequest 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
application :: a
idp :: Idp i
..} Manager
mgr ExchangeTokenInfo a
exchangeToken = do
  let tokenReq :: TokenRequest a
tokenReq = forall a.
HasTokenRequest a =>
a -> ExchangeTokenInfo a -> TokenRequest a
mkTokenRequestParam a
application ExchangeTokenInfo a
exchangeToken
      body :: [(ByteString, ByteString)]
body = [Map Text Text] -> [(ByteString, ByteString)]
unionMapsToQueryParams [forall a. ToQueryParam a => a -> Map Text Text
toQueryParam TokenRequest a
tokenReq]
  if forall a.
HasTokenRequestClientAuthenticationMethod a =>
a -> ClientAuthenticationMethod
getClientAuthenticationMethod a
application forall a. Eq a => a -> a -> Bool
== ClientAuthenticationMethod
ClientAssertionJwt
    then do
      ByteString
resp <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Request
req <- forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest (forall k (i :: k). Idp i -> URI
idpTokenEndpoint Idp i
idp)
        let req' :: Request
req' = [(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
body (Request -> Request
addDefaultRequestHeaders Request
req)
        Response ByteString -> Either TokenResponseError ByteString
handleOAuth2TokenResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req' Manager
mgr
      case forall a. FromJSON a => ByteString -> Either TokenResponseError a
parseResponseFlexible ByteString
resp of
        Right OAuth2Token
obj -> forall (m :: * -> *) a. Monad m => a -> m a
return OAuth2Token
obj
        Left TokenResponseError
e -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TokenResponseError
e
    else forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager
-> OAuth2
-> URI
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m a
doJSONPostRequest Manager
mgr (forall a. HasOAuth2Key a => a -> OAuth2
mkOAuth2Key a
application) (forall k (i :: k). Idp i -> URI
idpTokenEndpoint Idp i
idp) [(ByteString, ByteString)]
body

-------------------------------------------------------------------------------
--                                    PKCE                                   --
-------------------------------------------------------------------------------

-- | Make Token Request (PKCE)
-- 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 OAuth2Token
conduitPkceTokenRequest :: forall {k} a (m :: * -> *) (i :: k).
(HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
IdpApplication i a
-> Manager
-> (ExchangeTokenInfo a, CodeVerifier)
-> ExceptT TokenResponseError m OAuth2Token
conduitPkceTokenRequest IdpApplication {a
Idp i
application :: a
idp :: Idp i
application :: forall k (i :: k) a. IdpApplication i a -> a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
..} Manager
mgr (ExchangeTokenInfo a
exchangeToken, CodeVerifier
codeVerifier) =
  let req :: TokenRequest a
req = forall a.
HasTokenRequest a =>
a -> ExchangeTokenInfo a -> TokenRequest a
mkTokenRequestParam a
application ExchangeTokenInfo a
exchangeToken
      key :: OAuth2
key = forall a. HasOAuth2Key a => a -> OAuth2
mkOAuth2Key a
application
      clientSecretPostParam :: [(ByteString, ByteString)]
clientSecretPostParam =
        if forall a.
HasTokenRequestClientAuthenticationMethod a =>
a -> ClientAuthenticationMethod
getClientAuthenticationMethod a
application forall a. Eq a => a -> a -> Bool
== ClientAuthenticationMethod
ClientSecretPost
          then OAuth2 -> [(ByteString, ByteString)]
clientSecretPost OAuth2
key
          else []
      body :: [(ByteString, ByteString)]
body =
        [Map Text Text] -> [(ByteString, ByteString)]
unionMapsToQueryParams
          [ forall a. ToQueryParam a => a -> Map Text Text
toQueryParam TokenRequest a
req
          , forall a. ToQueryParam a => a -> Map Text Text
toQueryParam CodeVerifier
codeVerifier
          ]
          forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)]
clientSecretPostParam
   in forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager
-> OAuth2
-> URI
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m a
doJSONPostRequest Manager
mgr OAuth2
key (forall k (i :: k). Idp i -> URI
idpTokenEndpoint Idp i
idp) [(ByteString, ByteString)]
body