{-# 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
idp :: Idp i
application :: a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
application :: forall k (i :: k) a. IdpApplication i a -> a
..} Manager
mgr ExchangeTokenInfo a
exchangeToken = do
  let tokenReq :: TokenRequest a
tokenReq = a -> ExchangeTokenInfo a -> TokenRequest a
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 [TokenRequest a -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam TokenRequest a
tokenReq]
  if a -> ClientAuthenticationMethod
forall a.
HasTokenRequestClientAuthenticationMethod a =>
a -> ClientAuthenticationMethod
getClientAuthenticationMethod a
application ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== ClientAuthenticationMethod
ClientAssertionJwt
    then do
      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
$ do
        Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest (Idp i -> URI
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 (Response ByteString -> Either TokenResponseError ByteString)
-> IO (Response ByteString)
-> IO (Either TokenResponseError ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req' Manager
mgr
      case ByteString -> Either TokenResponseError OAuth2Token
forall a. FromJSON a => ByteString -> Either TokenResponseError a
parseResponseFlexible ByteString
resp of
        Right OAuth2Token
obj -> OAuth2Token -> ExceptT TokenResponseError m OAuth2Token
forall a. a -> ExceptT TokenResponseError m a
forall (m :: * -> *) a. Monad m => a -> m a
return OAuth2Token
obj
        Left TokenResponseError
e -> TokenResponseError -> ExceptT TokenResponseError m OAuth2Token
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TokenResponseError
e
    else Manager
-> OAuth2
-> URI
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m OAuth2Token
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager
-> OAuth2
-> URI
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m a
doJSONPostRequest Manager
mgr (a -> OAuth2
forall a. HasOAuth2Key a => a -> OAuth2
mkOAuth2Key a
application) (Idp i -> URI
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
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
application :: forall k (i :: k) a. IdpApplication i a -> a
idp :: Idp i
application :: a
..} 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 a
application ExchangeTokenInfo a
exchangeToken
      key :: OAuth2
key = a -> OAuth2
forall a. HasOAuth2Key a => a -> OAuth2
mkOAuth2Key a
application
      clientSecretPostParam :: [(ByteString, ByteString)]
clientSecretPostParam =
        if a -> ClientAuthenticationMethod
forall a.
HasTokenRequestClientAuthenticationMethod a =>
a -> ClientAuthenticationMethod
getClientAuthenticationMethod a
application ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
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
          [ 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
          ]
          [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)]
clientSecretPostParam
   in Manager
-> OAuth2
-> URI
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m OAuth2Token
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager
-> OAuth2
-> URI
-> [(ByteString, ByteString)]
-> ExceptT TokenResponseError m a
doJSONPostRequest Manager
mgr OAuth2
key (Idp i -> URI
forall k (i :: k). Idp i -> URI
idpTokenEndpoint Idp i
idp) [(ByteString, ByteString)]
body