AuthorizationCode.hs

{-# LANGUAGE FlexibleInstances #-}

module Network.OAuth2.Experiment.Grants.AuthorizationCode where

import Control.Monad.IO.Class (MonadIO (..))
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Text.Lazy (Text)
import Network.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..))
import Network.OAuth2 qualified as OAuth2
import Network.OAuth2.Experiment.Flows.AuthorizationRequest
import Network.OAuth2.Experiment.Flows.RefreshTokenRequest
import Network.OAuth2.Experiment.Flows.TokenRequest
import Network.OAuth2.Experiment.Flows.UserInfoRequest
import Network.OAuth2.Experiment.Pkce
import Network.OAuth2.Experiment.Types
import Network.OAuth2.Experiment.Utils
import URI.ByteString hiding (UserInfo)

-- | An Application that supports "Authorization code" flow
--
-- https://www.rfc-editor.org/rfc/rfc6749#section-4.1
data AuthorizationCodeApplication = AuthorizationCodeApplication
  { acName :: Text
  , acClientId :: ClientId
  , acClientSecret :: ClientSecret
  , acScope :: Set Scope
  , acRedirectUri :: URI
  , acAuthorizeState :: AuthorizeState
  , acAuthorizeRequestExtraParams :: Map Text Text
  , acClientAuthenticationMethod :: ClientAuthenticationMethod
  }

instance HasClientAuthenticationMethod AuthorizationCodeApplication where
  getClientAuthenticationMethod :: AuthorizationCodeApplication -> ClientAuthenticationMethod
  getClientAuthenticationMethod AuthorizationCodeApplication {..} = acClientAuthenticationMethod
  addClientAuthToHeader AuthorizationCodeApplication {..} = addSecretToHeader acClientId acClientSecret

mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam
mkAuthorizationRequestParam AuthorizationCodeApplication {..} =
  AuthorizationRequestParam
    { arScope = acScope
    , arState = acAuthorizeState
    , arClientId = acClientId
    , arRedirectUri = Just (RedirectUri acRedirectUri)
    , arResponseType = Code
    , arExtraParams = acAuthorizeRequestExtraParams
    }

mkPkceAuthorizeRequestParam :: MonadIO m => AuthorizationCodeApplication -> m (AuthorizationRequestParam, CodeVerifier)
mkPkceAuthorizeRequestParam app = do
  PkceRequestParam {..} <- mkPkceParam
  let authReqParam = mkAuthorizationRequestParam app
      combinatedExtraParams =
        Map.unions
          [ arExtraParams authReqParam
          , toQueryParam codeChallenge
          , toQueryParam codeChallengeMethod
          ]
  pure (authReqParam {arExtraParams = combinatedExtraParams}, codeVerifier)

-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3
instance HasTokenRequest AuthorizationCodeApplication where
  type ExchangeTokenInfo AuthorizationCodeApplication = ExchangeToken
  data TokenRequest AuthorizationCodeApplication = AuthorizationCodeTokenRequest
    { trCode :: ExchangeToken
    , trGrantType :: GrantTypeValue
    , trRedirectUri :: RedirectUri
    , trClientId :: ClientId
    , trClientSecret :: ClientSecret
    , trClientAuthenticationMethod :: ClientAuthenticationMethod
    }

  mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication
  mkTokenRequestParam AuthorizationCodeApplication {..} authCode =
    AuthorizationCodeTokenRequest
      { trCode = authCode
      , trGrantType = GTAuthorizationCode
      , trRedirectUri = RedirectUri acRedirectUri
      , trClientId = acClientId
      , trClientSecret = acClientSecret
      , trClientAuthenticationMethod = acClientAuthenticationMethod
      }

instance ToQueryParam (TokenRequest AuthorizationCodeApplication) where
  toQueryParam :: TokenRequest AuthorizationCodeApplication -> Map Text Text
  toQueryParam AuthorizationCodeTokenRequest {..} =
    let extraBodyBasedOnClientAuthMethod =
          case trClientAuthenticationMethod of
            ClientAssertionJwt ->
              [ Map.fromList
                  [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer")
                  , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret)
                  ]
              ]
            ClientSecretPost -> [toQueryParam trClientId, toQueryParam trClientSecret]
            ClientSecretBasic -> []
     in Map.unions $
          [ toQueryParam trCode
          , toQueryParam trGrantType
          , toQueryParam trRedirectUri
          ]
            ++ extraBodyBasedOnClientAuthMethod

instance HasUserInfoRequest AuthorizationCodeApplication

instance HasRefreshTokenRequest AuthorizationCodeApplication where
  mkRefreshTokenRequestParam :: AuthorizationCodeApplication -> OAuth2.RefreshToken -> RefreshTokenRequest
  mkRefreshTokenRequestParam AuthorizationCodeApplication {..} rt =
    RefreshTokenRequest
      { rrScope = acScope
      , rrGrantType = GTRefreshToken
      , rrRefreshToken = rt
      , rrClientId = if acClientAuthenticationMethod == ClientSecretPost then Just acClientId else Nothing
      , rrClientSecret = if acClientAuthenticationMethod == ClientSecretPost then Just acClientSecret else Nothing
      }