{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}

module Network.OAuth2.Experiment.Types where

import Data.Default (Default (def))
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.String
import Data.Text.Lazy (Text)
import Data.Text.Lazy qualified as TL
import Network.OAuth.OAuth2 hiding (RefreshToken)
import Network.OAuth.OAuth2 qualified as OAuth2
import Network.OAuth2.Experiment.Pkce
import Network.OAuth2.Experiment.Utils
import URI.ByteString (URI, serializeURIRef')

-------------------------------------------------------------------------------

-- * Idp App

-------------------------------------------------------------------------------

-- TODO: Distinct type per endpoint
-- Because I made mistake at passing to Authorize and Token Request

-- | @Idp i@ consists various endpoints endpoints.
--
-- The @i@ is actually phantom type for information only (Idp name) at this moment.
-- And it is PolyKinds.
--
-- Hence whenever @Idp i@ or @IdpApplication i a@ is used as function parameter,
-- PolyKinds need to be enabled.
data Idp (i :: k) = Idp
  { forall k (i :: k). Idp i -> URI
idpUserInfoEndpoint :: URI
  -- ^ Userinfo Endpoint
  , forall k (i :: k). Idp i -> URI
idpAuthorizeEndpoint :: URI
  -- ^ Authorization Endpoint
  , forall k (i :: k). Idp i -> URI
idpTokenEndpoint :: URI
  -- ^ Token Endpoint
  , forall k (i :: k). Idp i -> Maybe URI
idpDeviceAuthorizationEndpoint :: Maybe URI
  -- ^ Apparently not all IdP support device code flow
  }

-- | An OAuth2 Application "a" of IdP "i".
-- "a" can be one of following type:
--
-- * `Network.OAuth2.Experiment.AuthorizationCodeApplication`
-- * `Network.OAuth2.Experiment.DeviceAuthorizationApplication`
-- * `Network.OAuth2.Experiment.ClientCredentialsApplication`
-- * `Network.OAuth2.Experiment.ResourceOwnerPasswordApplication`
-- * `Network.OAuth2.Experiment.JwtBearerApplication`
data IdpApplication (i :: k) a = IdpApplication
  { forall k (i :: k) a. IdpApplication i a -> Idp i
idp :: Idp i
  , forall k (i :: k) a. IdpApplication i a -> a
application :: a
  }

-------------------------------------------------------------------------------

-- * Scope

-------------------------------------------------------------------------------

-- TODO: What's best type for Scope?
-- Use 'Text' isn't super type safe. All cannot specify some standard scopes like openid, email etc.
-- But Following data type is not ideal as Idp would have lots of 'Custom Text'
--
-- @
-- data Scope = OPENID | PROFILE | EMAIL | OFFLINE_ACCESS | Custom Text
-- @
--
-- Would be nice to define Enum for standard Scope, plus allow user to define their own define (per Idp) and plugin somehow.
newtype Scope = Scope {Scope -> Text
unScope :: Text}
  deriving (Scope -> Scope -> Bool
(Scope -> Scope -> Bool) -> (Scope -> Scope -> Bool) -> Eq Scope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Scope -> Scope -> Bool
== :: Scope -> Scope -> Bool
$c/= :: Scope -> Scope -> Bool
/= :: Scope -> Scope -> Bool
Eq, Eq Scope
Eq Scope =>
(Scope -> Scope -> Ordering)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Scope)
-> (Scope -> Scope -> Scope)
-> Ord Scope
Scope -> Scope -> Bool
Scope -> Scope -> Ordering
Scope -> Scope -> Scope
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Scope -> Scope -> Ordering
compare :: Scope -> Scope -> Ordering
$c< :: Scope -> Scope -> Bool
< :: Scope -> Scope -> Bool
$c<= :: Scope -> Scope -> Bool
<= :: Scope -> Scope -> Bool
$c> :: Scope -> Scope -> Bool
> :: Scope -> Scope -> Bool
$c>= :: Scope -> Scope -> Bool
>= :: Scope -> Scope -> Bool
$cmax :: Scope -> Scope -> Scope
max :: Scope -> Scope -> Scope
$cmin :: Scope -> Scope -> Scope
min :: Scope -> Scope -> Scope
Ord)

instance IsString Scope where
  fromString :: String -> Scope
  fromString :: String -> Scope
fromString = Text -> Scope
Scope (Text -> Scope) -> (String -> Text) -> String -> Scope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack

-------------------------------------------------------------------------------

-- * Grant Type value

-------------------------------------------------------------------------------

-- | Grant type query parameter has association with different GrantType flows but not completely strict.
--
-- e.g. Both AuthorizationCode and ResourceOwnerPassword flow could support refresh token flow.
data GrantTypeValue
  = GTAuthorizationCode
  | GTPassword
  | GTClientCredentials
  | GTRefreshToken
  | GTJwtBearer
  | GTDeviceCode
  deriving (GrantTypeValue -> GrantTypeValue -> Bool
(GrantTypeValue -> GrantTypeValue -> Bool)
-> (GrantTypeValue -> GrantTypeValue -> Bool) -> Eq GrantTypeValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GrantTypeValue -> GrantTypeValue -> Bool
== :: GrantTypeValue -> GrantTypeValue -> Bool
$c/= :: GrantTypeValue -> GrantTypeValue -> Bool
/= :: GrantTypeValue -> GrantTypeValue -> Bool
Eq, Int -> GrantTypeValue -> ShowS
[GrantTypeValue] -> ShowS
GrantTypeValue -> String
(Int -> GrantTypeValue -> ShowS)
-> (GrantTypeValue -> String)
-> ([GrantTypeValue] -> ShowS)
-> Show GrantTypeValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GrantTypeValue -> ShowS
showsPrec :: Int -> GrantTypeValue -> ShowS
$cshow :: GrantTypeValue -> String
show :: GrantTypeValue -> String
$cshowList :: [GrantTypeValue] -> ShowS
showList :: [GrantTypeValue] -> ShowS
Show)

-------------------------------------------------------------------------------
--                               Response Type                               --
-------------------------------------------------------------------------------
data ResponseType = Code

-------------------------------------------------------------------------------

-- * Credentials

-------------------------------------------------------------------------------
newtype ClientId = ClientId {ClientId -> Text
unClientId :: Text}
  deriving (Int -> ClientId -> ShowS
[ClientId] -> ShowS
ClientId -> String
(Int -> ClientId -> ShowS)
-> (ClientId -> String) -> ([ClientId] -> ShowS) -> Show ClientId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientId -> ShowS
showsPrec :: Int -> ClientId -> ShowS
$cshow :: ClientId -> String
show :: ClientId -> String
$cshowList :: [ClientId] -> ShowS
showList :: [ClientId] -> ShowS
Show, ClientId -> ClientId -> Bool
(ClientId -> ClientId -> Bool)
-> (ClientId -> ClientId -> Bool) -> Eq ClientId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientId -> ClientId -> Bool
== :: ClientId -> ClientId -> Bool
$c/= :: ClientId -> ClientId -> Bool
/= :: ClientId -> ClientId -> Bool
Eq, String -> ClientId
(String -> ClientId) -> IsString ClientId
forall a. (String -> a) -> IsString a
$cfromString :: String -> ClientId
fromString :: String -> ClientId
IsString)

-- | Can be either "Client Secret" or JWT base on client authentication method
newtype ClientSecret = ClientSecret {ClientSecret -> Text
unClientSecret :: Text}
  deriving (ClientSecret -> ClientSecret -> Bool
(ClientSecret -> ClientSecret -> Bool)
-> (ClientSecret -> ClientSecret -> Bool) -> Eq ClientSecret
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientSecret -> ClientSecret -> Bool
== :: ClientSecret -> ClientSecret -> Bool
$c/= :: ClientSecret -> ClientSecret -> Bool
/= :: ClientSecret -> ClientSecret -> Bool
Eq, String -> ClientSecret
(String -> ClientSecret) -> IsString ClientSecret
forall a. (String -> a) -> IsString a
$cfromString :: String -> ClientSecret
fromString :: String -> ClientSecret
IsString)

-- | In order to reuse some methods from legacy "Network.OAuth.OAuth2".
-- Will be removed when Experiment module becomes default.
toOAuth2Key :: ClientId -> ClientSecret -> OAuth2
toOAuth2Key :: ClientId -> ClientSecret -> OAuth2
toOAuth2Key ClientId
cid ClientSecret
csecret =
  OAuth2
forall a. Default a => a
def
    { oauth2ClientId = TL.toStrict $ unClientId cid
    , oauth2ClientSecret = TL.toStrict $ unClientSecret csecret
    }

newtype RedirectUri = RedirectUri {RedirectUri -> URI
unRedirectUri :: URI}
  deriving (RedirectUri -> RedirectUri -> Bool
(RedirectUri -> RedirectUri -> Bool)
-> (RedirectUri -> RedirectUri -> Bool) -> Eq RedirectUri
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RedirectUri -> RedirectUri -> Bool
== :: RedirectUri -> RedirectUri -> Bool
$c/= :: RedirectUri -> RedirectUri -> Bool
/= :: RedirectUri -> RedirectUri -> Bool
Eq)

newtype AuthorizeState = AuthorizeState {AuthorizeState -> Text
unAuthorizeState :: Text}
  deriving (AuthorizeState -> AuthorizeState -> Bool
(AuthorizeState -> AuthorizeState -> Bool)
-> (AuthorizeState -> AuthorizeState -> Bool) -> Eq AuthorizeState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AuthorizeState -> AuthorizeState -> Bool
== :: AuthorizeState -> AuthorizeState -> Bool
$c/= :: AuthorizeState -> AuthorizeState -> Bool
/= :: AuthorizeState -> AuthorizeState -> Bool
Eq)

instance IsString AuthorizeState where
  fromString :: String -> AuthorizeState
  fromString :: String -> AuthorizeState
fromString = Text -> AuthorizeState
AuthorizeState (Text -> AuthorizeState)
-> (String -> Text) -> String -> AuthorizeState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack

newtype Username = Username {Username -> Text
unUsername :: Text}
  deriving (Username -> Username -> Bool
(Username -> Username -> Bool)
-> (Username -> Username -> Bool) -> Eq Username
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Username -> Username -> Bool
== :: Username -> Username -> Bool
$c/= :: Username -> Username -> Bool
/= :: Username -> Username -> Bool
Eq)

instance IsString Username where
  fromString :: String -> Username
  fromString :: String -> Username
fromString = Text -> Username
Username (Text -> Username) -> (String -> Text) -> String -> Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack

newtype Password = Password {Password -> Text
unPassword :: Text}
  deriving (Password -> Password -> Bool
(Password -> Password -> Bool)
-> (Password -> Password -> Bool) -> Eq Password
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Password -> Password -> Bool
== :: Password -> Password -> Bool
$c/= :: Password -> Password -> Bool
/= :: Password -> Password -> Bool
Eq)

instance IsString Password where
  fromString :: String -> Password
  fromString :: String -> Password
fromString = Text -> Password
Password (Text -> Password) -> (String -> Text) -> String -> Password
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack

-------------------------------------------------------------------------------

-- * Query parameters

-------------------------------------------------------------------------------
class ToQueryParam a where
  toQueryParam :: a -> Map Text Text

instance ToQueryParam a => ToQueryParam (Maybe a) where
  toQueryParam :: ToQueryParam a => Maybe a -> Map Text Text
  toQueryParam :: ToQueryParam a => Maybe a -> Map Text Text
toQueryParam Maybe a
Nothing = Map Text Text
forall k a. Map k a
Map.empty
  toQueryParam (Just a
a) = a -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam a
a

instance ToQueryParam GrantTypeValue where
  toQueryParam :: GrantTypeValue -> Map Text Text
  toQueryParam :: GrantTypeValue -> Map Text Text
toQueryParam GrantTypeValue
x = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"grant_type" (GrantTypeValue -> Text
val GrantTypeValue
x)
    where
      val :: GrantTypeValue -> Text
      val :: GrantTypeValue -> Text
val GrantTypeValue
GTAuthorizationCode = Text
"authorization_code"
      val GrantTypeValue
GTPassword = Text
"password"
      val GrantTypeValue
GTClientCredentials = Text
"client_credentials"
      val GrantTypeValue
GTRefreshToken = Text
"refresh_token"
      val GrantTypeValue
GTJwtBearer = Text
"urn:ietf:params:oauth:grant-type:jwt-bearer"
      val GrantTypeValue
GTDeviceCode = Text
"urn:ietf:params:oauth:grant-type:device_code"

instance ToQueryParam ClientId where
  toQueryParam :: ClientId -> Map Text Text
  toQueryParam :: ClientId -> Map Text Text
toQueryParam (ClientId Text
i) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"client_id" Text
i

instance ToQueryParam ClientSecret where
  toQueryParam :: ClientSecret -> Map Text Text
  toQueryParam :: ClientSecret -> Map Text Text
toQueryParam (ClientSecret Text
x) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"client_secret" Text
x

instance ToQueryParam Username where
  toQueryParam :: Username -> Map Text Text
  toQueryParam :: Username -> Map Text Text
toQueryParam (Username Text
x) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"username" Text
x

instance ToQueryParam Password where
  toQueryParam :: Password -> Map Text Text
  toQueryParam :: Password -> Map Text Text
toQueryParam (Password Text
x) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"password" Text
x

instance ToQueryParam AuthorizeState where
  toQueryParam :: AuthorizeState -> Map Text Text
  toQueryParam :: AuthorizeState -> Map Text Text
toQueryParam (AuthorizeState Text
x) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"state" Text
x

instance ToQueryParam RedirectUri where
  toQueryParam :: RedirectUri -> Map Text Text
toQueryParam (RedirectUri URI
uri) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"redirect_uri" (ByteString -> Text
bs8ToLazyText (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' URI
uri)

instance ToQueryParam (Set Scope) where
  toQueryParam :: Set Scope -> Map Text Text
  toQueryParam :: Set Scope -> Map Text Text
toQueryParam = Set Text -> Map Text Text
forall a. IsString a => Set Text -> Map a Text
toScopeParam (Set Text -> Map Text Text)
-> (Set Scope -> Set Text) -> Set Scope -> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scope -> Text) -> Set Scope -> Set Text
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Scope -> Text
unScope
    where
      toScopeParam :: IsString a => Set Text -> Map a Text
      toScopeParam :: forall a. IsString a => Set Text -> Map a Text
toScopeParam Set Text
scope = a -> Text -> Map a Text
forall k a. k -> a -> Map k a
Map.singleton a
"scope" (Text -> [Text] -> Text
TL.intercalate Text
" " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
scope)

instance ToQueryParam CodeVerifier where
  toQueryParam :: CodeVerifier -> Map Text Text
  toQueryParam :: CodeVerifier -> Map Text Text
toQueryParam (CodeVerifier Text
x) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"code_verifier" (Text -> Text
TL.fromStrict Text
x)

instance ToQueryParam CodeChallenge where
  toQueryParam :: CodeChallenge -> Map Text Text
  toQueryParam :: CodeChallenge -> Map Text Text
toQueryParam (CodeChallenge Text
x) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"code_challenge" (Text -> Text
TL.fromStrict Text
x)

instance ToQueryParam CodeChallengeMethod where
  toQueryParam :: CodeChallengeMethod -> Map Text Text
  toQueryParam :: CodeChallengeMethod -> Map Text Text
toQueryParam CodeChallengeMethod
x = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"code_challenge_method" (String -> Text
TL.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ CodeChallengeMethod -> String
forall a. Show a => a -> String
show CodeChallengeMethod
x)

instance ToQueryParam ExchangeToken where
  toQueryParam :: ExchangeToken -> Map Text Text
  toQueryParam :: ExchangeToken -> Map Text Text
toQueryParam (ExchangeToken Text
x) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"code" (Text -> Text
TL.fromStrict Text
x)

instance ToQueryParam OAuth2.RefreshToken where
  toQueryParam :: OAuth2.RefreshToken -> Map Text Text
  toQueryParam :: RefreshToken -> Map Text Text
toQueryParam (OAuth2.RefreshToken Text
x) = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"refresh_token" (Text -> Text
TL.fromStrict Text
x)

instance ToQueryParam ResponseType where
  toQueryParam :: ResponseType -> Map Text Text
  toQueryParam :: ResponseType -> Map Text Text
toQueryParam ResponseType
Code = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"response_type" Text
"code"

-------------------------------------------------------------------------------
--                                HasOAuth2Key                               --
--                                                                           --
-- Find a way to reuse some methods from old implementation                  --
-- Probably will be removed when Experiment module becomes default           --
-------------------------------------------------------------------------------

class HasOAuth2Key a where
  mkOAuth2Key :: a -> OAuth2