    {-# 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