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
arScope :: AuthorizationRequestParam -> Set Scope
arState :: AuthorizationRequestParam -> AuthorizeState
arClientId :: AuthorizationRequestParam -> ClientId
arRedirectUri :: AuthorizationRequestParam -> Maybe RedirectUri
arResponseType :: AuthorizationRequestParam -> ResponseType
arExtraParams :: AuthorizationRequestParam -> Map Text Text
arScope :: Set Scope
arState :: AuthorizeState
arClientId :: ClientId
arRedirectUri :: Maybe RedirectUri
arResponseType :: ResponseType
arExtraParams :: Map Text Text
..} =
    [Map Text Text] -> Map Text Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
      [ ResponseType -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam ResponseType
arResponseType
      , Set Scope -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam Set Scope
arScope
      , ClientId -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam ClientId
arClientId
      , AuthorizeState -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam AuthorizeState
arState
      , Maybe RedirectUri -> Map Text Text
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 = a -> AuthorizationRequestParam
forall a. HasAuthorizeRequest a => a -> AuthorizationRequestParam
mkAuthorizationRequestParam (IdpApplication i a -> a
forall k (i :: k) a. IdpApplication i a -> a
application IdpApplication i a
idpApp)
      allParams :: [(ByteString, ByteString)]
allParams =
        ((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
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) ([(Text, Text)] -> [(ByteString, ByteString)])
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$
          Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$
            AuthorizationRequestParam -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam AuthorizationRequestParam
req
   in [(ByteString, ByteString)] -> URI -> URI
forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString, ByteString)]
allParams (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$
        Idp i -> URI
forall k (i :: k). Idp i -> URI
idpAuthorizeEndpoint (IdpApplication i a -> Idp i
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 :: forall k (i :: k) a. IdpApplication i a -> a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
idp :: Idp i
application :: a
..} = do
  (AuthorizationRequestParam
req, CodeVerifier
codeVerifier) <- a -> m (AuthorizationRequestParam, CodeVerifier)
forall a (m :: * -> *).
(HasPkceAuthorizeRequest a, MonadIO m) =>
a -> m (AuthorizationRequestParam, CodeVerifier)
forall (m :: * -> *).
MonadIO m =>
a -> m (AuthorizationRequestParam, CodeVerifier)
mkPkceAuthorizeRequestParam a
application
  let allParams :: [(ByteString, ByteString)]
allParams = ((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
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) ([(Text, Text)] -> [(ByteString, ByteString)])
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ AuthorizationRequestParam -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam AuthorizationRequestParam
req
  let url :: URI
url =
        [(ByteString, ByteString)] -> URI -> URI
forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString, ByteString)]
allParams (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$
          Idp i -> URI
forall k (i :: k). Idp i -> URI
idpAuthorizeEndpoint Idp i
idp
  (URI, CodeVerifier) -> m (URI, CodeVerifier)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI
url, CodeVerifier
codeVerifier)