module Network.OAuth2.Experiment.Flows.AuthorizationRequest where

import Control.Monad.IO.Class (MonadIO (..))
import Data.Bifunctor
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Text.Lazy (Text)
import Network.OAuth.OAuth2 hiding (RefreshToken)
import Network.OAuth2.Experiment.Pkce
import Network.OAuth2.Experiment.Types
import Network.OAuth2.Experiment.Utils
import URI.ByteString hiding (UserInfo)

-------------------------------------------------------------------------------
--                           Authorization Request                           --
-------------------------------------------------------------------------------

data AuthorizationRequestParam = AuthorizationRequestParam
  { AuthorizationRequestParam -> Set Scope
arScope :: Set Scope
  , AuthorizationRequestParam -> AuthorizeState
arState :: AuthorizeState
  , AuthorizationRequestParam -> ClientId
arClientId :: ClientId
  , AuthorizationRequestParam -> Maybe RedirectUri
arRedirectUri :: Maybe RedirectUri
  , AuthorizationRequestParam -> ResponseType
arResponseType :: ResponseType
  -- ^ It could be optional there is only one redirect_uri registered.
  -- See: https://www.rfc-editor.org/rfc/rfc6749#section-3.1.2.3
  , AuthorizationRequestParam -> Map Text Text
arExtraParams :: Map Text Text
  }

instance ToQueryParam AuthorizationRequestParam where
  toQueryParam :: AuthorizationRequestParam -> Map Text Text
toQueryParam AuthorizationRequestParam {Maybe RedirectUri
Map Text Text
Set Scope
AuthorizeState
ClientId
ResponseType
arExtraParams :: Map Text Text
arResponseType :: ResponseType
arRedirectUri :: Maybe RedirectUri
arClientId :: ClientId
arState :: AuthorizeState
arScope :: Set Scope
arExtraParams :: AuthorizationRequestParam -> Map Text Text
arResponseType :: AuthorizationRequestParam -> ResponseType
arRedirectUri :: AuthorizationRequestParam -> Maybe RedirectUri
arClientId :: AuthorizationRequestParam -> ClientId
arState :: AuthorizationRequestParam -> AuthorizeState
arScope :: AuthorizationRequestParam -> Set Scope
..} =
    forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
      [ forall a. ToQueryParam a => a -> Map Text Text
toQueryParam ResponseType
arResponseType
      , forall a. ToQueryParam a => a -> Map Text Text
toQueryParam Set Scope
arScope
      , forall a. ToQueryParam a => a -> Map Text Text
toQueryParam ClientId
arClientId
      , forall a. ToQueryParam a => a -> Map Text Text
toQueryParam AuthorizeState
arState
      , forall a. ToQueryParam a => a -> Map Text Text
toQueryParam Maybe RedirectUri
arRedirectUri
      , Map Text Text
arExtraParams
      ]

class HasAuthorizeRequest a where
  -- | Constructs Authorization Code request parameters
  -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1
  mkAuthorizationRequestParam :: a -> AuthorizationRequestParam

-- | Constructs Authorization Code request URI
-- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1
mkAuthorizationRequest :: HasAuthorizeRequest a => IdpApplication i a -> URI
mkAuthorizationRequest :: forall {k} a (i :: k).
HasAuthorizeRequest a =>
IdpApplication i a -> URI
mkAuthorizationRequest IdpApplication i a
idpApp =
  let req :: AuthorizationRequestParam
req = forall a. HasAuthorizeRequest a => a -> AuthorizationRequestParam
mkAuthorizationRequestParam (forall k (i :: k) a. IdpApplication i a -> a
application IdpApplication i a
idpApp)
      allParams :: [(ByteString, ByteString)]
allParams =
        forall a b. (a -> b) -> [a] -> [b]
map (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) forall a b. (a -> b) -> a -> b
$
          forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$
            forall a. ToQueryParam a => a -> Map Text Text
toQueryParam AuthorizationRequestParam
req
   in forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString, ByteString)]
allParams forall a b. (a -> b) -> a -> b
$
        forall k (i :: k). Idp i -> URI
idpAuthorizeEndpoint (forall k (i :: k) a. IdpApplication i a -> Idp i
idp IdpApplication i a
idpApp)

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

-- | https://datatracker.ietf.org/doc/html/rfc7636
class HasAuthorizeRequest a => HasPkceAuthorizeRequest a where
  mkPkceAuthorizeRequestParam :: MonadIO m => a -> m (AuthorizationRequestParam, CodeVerifier)

-- | Constructs Authorization Code (PKCE) request URI and the Code Verifier.
-- https://datatracker.ietf.org/doc/html/rfc7636
mkPkceAuthorizeRequest ::
  (MonadIO m, HasPkceAuthorizeRequest a) =>
  IdpApplication i a ->
  m (URI, CodeVerifier)
mkPkceAuthorizeRequest :: forall {k} (m :: * -> *) a (i :: k).
(MonadIO m, HasPkceAuthorizeRequest a) =>
IdpApplication i a -> m (URI, CodeVerifier)
mkPkceAuthorizeRequest IdpApplication {a
Idp i
application :: a
idp :: Idp i
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
application :: forall k (i :: k) a. IdpApplication i a -> a
..} = do
  (AuthorizationRequestParam
req, CodeVerifier
codeVerifier) <- forall a (m :: * -> *).
(HasPkceAuthorizeRequest a, MonadIO m) =>
a -> m (AuthorizationRequestParam, CodeVerifier)
mkPkceAuthorizeRequestParam a
application
  let allParams :: [(ByteString, ByteString)]
allParams = forall a b. (a -> b) -> [a] -> [b]
map (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) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall a. ToQueryParam a => a -> Map Text Text
toQueryParam AuthorizationRequestParam
req
  let url :: URI
url =
        forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString, ByteString)]
allParams forall a b. (a -> b) -> a -> b
$
          forall k (i :: k). Idp i -> URI
idpAuthorizeEndpoint Idp i
idp
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI
url, CodeVerifier
codeVerifier)