{-|

Copyright:

  This file is part of the package openid-connect.  It is subject to
  the license terms in the LICENSE file found in the top-level
  directory of this distribution and at:

    https://code.devalot.com/open/openid-connect

  No part of this package, including this file, may be copied,
  modified, propagated, or distributed except according to the terms
  contained in the LICENSE file.

License: BSD-2-Clause

The /Authorization Code/ Flow as defined in OpenID Connect 1.0.

Flow outline:

  1. Perform (and optionally cache) the provider's discovery document
     and keys.  This is done with a combination of
     'OpenID.Connect.Client.Provider.discovery' and
     'OpenID.Connect.Client.Provider.keysFromDiscovery'.

  2. Send the end-user to the provider for authentication by applying
     the 'authenticationRedirect' function.  It will generate a
     'RedirectTo' response with a URI and cookie.

  3. The provider will redirect the end-user back to your site with
     some query parameters.  Bundle those up and apply the
     'authenticationSuccess' function.  It will respond with a
     validated identity token if everything checks out.
-}
module OpenID.Connect.Client.Flow.AuthorizationCode
  (
    -- * Flow
    authenticationRedirect
  , authenticationSuccess
  , authenticationSuccessWithJwt
  , RedirectTo(..)

    -- * Authentication settings
  , defaultAuthenticationRequest

    -- * End-user provided details
  , UserReturnFromRedirect(..)

    -- * Errors that can occur
  , FlowError(..)

    -- * Ancillary types and re-exports
  , HTTPS
  , ErrorResponse(..)
  , module OpenID.Connect.Authentication
  , module OpenID.Connect.Client.Provider
  , module OpenID.Connect.Scope
  ) where

--------------------------------------------------------------------------------
-- Imports:
import Control.Category ((>>>))
import Control.Exception (Exception)
import Control.Monad.Except
import qualified Crypto.Hash as Hash
import qualified Crypto.JOSE.Error as JOSE
import Crypto.JOSE.JWK (JWKSet)
import Crypto.JWT (SignedJWT, ClaimsSet, JWTError)
import Crypto.Random (MonadRandom(..))
import Data.Bifunctor (bimap, first, second)
import Data.ByteArray.Encoding
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Lazy as LByteString
import Data.Function ((&))
import Data.Functor ((<&>))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Data.Time.Clock (UTCTime)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Types (QueryItem, renderQuery)
import qualified Network.URI as Network
import OpenID.Connect.Authentication
import OpenID.Connect.Client.Authentication
import OpenID.Connect.Client.HTTP
import OpenID.Connect.Client.Provider
import OpenID.Connect.JSON
import OpenID.Connect.Scope
import OpenID.Connect.TokenResponse (TokenResponse (idToken))
import Web.Cookie (SetCookie)
import qualified Web.Cookie as Cookie

import OpenID.Connect.Client.TokenResponse
  ( decodeIdentityToken
  , verifyIdentityTokenClaims
  )

--------------------------------------------------------------------------------
-- | Internal type for calculating secrets.
data Secrets = Secrets
  { Secrets -> ByteString
requestForgeryProtectionToken :: ByteString
  , Secrets -> ByteString
replayProtectionNonce         :: ByteString
  , Secrets -> ByteString
valueForHttpOnlyCookie        :: ByteString
  }

--------------------------------------------------------------------------------
-- | Generate a new set of secrets.
generateRandomSecrets :: forall m. MonadRandom m => m Secrets
generateRandomSecrets :: forall (m :: * -> *). MonadRandom m => m Secrets
generateRandomSecrets = do
  ByteString
bytes <- forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
64 :: m ByteString
  let hash1 :: Digest SHA256
hash1 = forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash (Int -> ByteString -> ByteString
ByteString.take Int
32 ByteString
bytes) :: Hash.Digest Hash.SHA256
      hash2 :: Digest SHA256
hash2 = forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash (Int -> ByteString -> ByteString
ByteString.drop Int
32 ByteString
bytes) :: Hash.Digest Hash.SHA256

  forall (f :: * -> *) a. Applicative f => a -> f a
pure Secrets
    { requestForgeryProtectionToken :: ByteString
requestForgeryProtectionToken = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded Digest SHA256
hash2
    , replayProtectionNonce :: ByteString
replayProtectionNonce         = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded Digest SHA256
hash1
    , valueForHttpOnlyCookie :: ByteString
valueForHttpOnlyCookie        = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded ByteString
bytes
    }

--------------------------------------------------------------------------------
-- | Extract the expected state value from the session cookie.
expectedStateParam :: ByteString -> Either FlowError ByteString
expectedStateParam :: ByteString -> Either FlowError ByteString
expectedStateParam ByteString
cookie
  = ByteString
-> (ByteString -> ByteString) -> Either String ByteString
extractTokenFromSessionCookie ByteString
cookie (Int -> ByteString -> ByteString
ByteString.drop Int
32)
  forall a b. a -> (a -> b) -> b
& forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. a -> b -> a
const FlowError
InvalidStateParameterError)

--------------------------------------------------------------------------------
-- | Given the session cookie, return the expected nonce value.
expectedNonce :: ByteString -> Either FlowError Text
expectedNonce :: ByteString -> Either FlowError Text
expectedNonce ByteString
cookie
  = ByteString
-> (ByteString -> ByteString) -> Either String ByteString
extractTokenFromSessionCookie ByteString
cookie (Int -> ByteString -> ByteString
ByteString.take Int
32)
  forall a b. a -> (a -> b) -> b
& forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b. a -> b -> a
const FlowError
InvalidNonceFromProviderError) ByteString -> Text
Text.decodeUtf8

--------------------------------------------------------------------------------
-- | Higher-order function of extracting bytes from a session cookie.
extractTokenFromSessionCookie
  :: ByteString                 -- ^ The session cookie
  -> (ByteString -> ByteString) -- ^ Function to extract token bytes
  -> Either String ByteString   -- ^ Error or token.
extractTokenFromSessionCookie :: ByteString
-> (ByteString -> ByteString) -> Either String ByteString
extractTokenFromSessionCookie ByteString
cookie ByteString -> ByteString
f =
    forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64URLUnpadded ByteString
cookie forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> ByteString
rehash forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
f
  where
    rehash :: ByteString -> ByteString
    rehash :: ByteString -> ByteString
rehash ByteString
bs = let hash :: Digest SHA256
hash = forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash ByteString
bs :: Hash.Digest Hash.SHA256
                in forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded Digest SHA256
hash

--------------------------------------------------------------------------------
-- | Create an 'AuthenticationRequest' value for the authorization
-- code flow.
--
-- @since 0.1.0.0
defaultAuthenticationRequest
  :: Scope                 -- ^ Requested scope.
  -> Credentials           -- ^ Provider assigned credentials.
  -> AuthenticationRequest -- ^ An 'AuthenticationRequest'.
defaultAuthenticationRequest :: Scope -> Credentials -> AuthenticationRequest
defaultAuthenticationRequest Scope
scope Credentials
creds =
  AuthenticationRequest
    { authRequestRedirectURI :: ClientRedirectURI
authRequestRedirectURI  = Credentials -> ClientRedirectURI
clientRedirectUri Credentials
creds
    , authRequestScope :: Scope
authRequestScope        = Scope
scope
    , authRequestResponseType :: ByteString
authRequestResponseType = ByteString
"code"
    , authRequestClientId :: Text
authRequestClientId     = Credentials -> Text
assignedClientId Credentials
creds
    , authRequestDisplay :: Maybe ByteString
authRequestDisplay      = forall a. Maybe a
Nothing
    , authRequestPrompt :: Maybe ByteString
authRequestPrompt       = forall a. Maybe a
Nothing
    , authRequestMaxAge :: Maybe Int
authRequestMaxAge       = forall a. Maybe a
Nothing
    , authRequestUiLocales :: Maybe Words
authRequestUiLocales    = forall a. Maybe a
Nothing
    , authRequestIdTokenHint :: Maybe ByteString
authRequestIdTokenHint  = forall a. Maybe a
Nothing
    , authRequestLoginHint :: Maybe Text
authRequestLoginHint    = forall a. Maybe a
Nothing
    , authRequestAcrValues :: Maybe Words
authRequestAcrValues    = forall a. Maybe a
Nothing
    , authRequestOtherParams :: Query
authRequestOtherParams  = []
    }

--------------------------------------------------------------------------------
-- | Values to collect from the end-user after they return from
-- provider authentication as per §3.1.2.5.
--
-- When the end-user is sent to the 'ClientRedirectURI' they /must/
-- provide the following values.  If any of these fields are not
-- provided by the end-user you should assume the authentication
-- failed.
--
-- If the @state@ and/or @code@ parameters are missing in the HTTP
-- request you should look for an @error@ query parameter as specified
-- in §3.1.2.6.
--
-- @since 0.1.0.0
data UserReturnFromRedirect = UserReturnFromRedirect
  { UserReturnFromRedirect -> ByteString
afterRedirectSessionCookie :: ByteString
    -- ^ The end-user /must/ provide a cookie value set by the
    -- 'RedirectTo' response.  This is needed to validate the @state@
    -- parameter and the @nonce@ claim in the identity token.

  , UserReturnFromRedirect -> ByteString
afterRedirectCodeParam :: ByteString
    -- ^ The @code@ parameter which contains the authorization code.

  , UserReturnFromRedirect -> ByteString
afterRedirectStateParam :: ByteString
    -- ^ The @state@ parameter which is used to prevent request
    -- forgery.
  }

--------------------------------------------------------------------------------
-- | Errors that may occur during the authentication code flow.
--
-- @since 0.1.0.0
data FlowError
  = ProviderDiscoveryError DiscoveryError
    -- ^ Something is wrong with the discovery document.

  | InvalidStateParameterError
    -- ^ The @state@ query parameter provided by the end-user doesn't
    -- match their session cookie.  It's possible that the current
    -- request was forged and therefore didn't originate from an
    -- actual end-user.

  | InvalidNonceFromProviderError
    -- ^ The @nonce@ claim in the identity token doesn't match the
    -- value in the end-user's session cookie.  It's possible that the
    -- response from the provider is a replay of a previous response.

  | ProviderMissingTokenEndpointError
    -- ^ The provider does not support the Authorization Code flow.
    -- To work with this provider you must use another flow type
    -- (i.e. implicit or hybrid).

  | InvalidProviderTokenEndpointError Text
    -- ^ The provider's discovery document includes a @token_endpoint@
    -- which is not a valid URL.  The invalid URL is provided for
    -- reference.

  | NoAuthenticationMethodsAvailableError
    -- ^ The provided 'Credentials' do not include any authentication
    -- secrets that match what the provider accepts in the
    -- 'tokenEndpointAuthMethodsSupported' field.  Therefore we can't
    -- make a token exchange request with this provider without using
    -- a different set of 'Credentials'.

  | InvalidProviderTokenResponseError ErrorResponse
    -- ^ While exchanging an authorization code for an identity token
    -- the provider responded in a way that we couldn't parse.  A
    -- decoding error message is provided for debugging.

  | TokenDecodingError JOSE.Error
    -- ^ The 'TokenResponse' from the provider failed to decode or
    -- validate.  More information is provided by the @jose@ error.

  | IdentityTokenValidationFailed JWTError
    -- ^ The identity token from the provider is invalid (i.e. one of
    -- the claims is incorrect) or the digital signature on the token
    -- doesn't match any of the keys in the provided key set.

  deriving (Int -> FlowError -> ShowS
[FlowError] -> ShowS
FlowError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FlowError] -> ShowS
$cshowList :: [FlowError] -> ShowS
show :: FlowError -> String
$cshow :: FlowError -> String
showsPrec :: Int -> FlowError -> ShowS
$cshowsPrec :: Int -> FlowError -> ShowS
Show, Show FlowError
Typeable FlowError
SomeException -> Maybe FlowError
FlowError -> String
FlowError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: FlowError -> String
$cdisplayException :: FlowError -> String
fromException :: SomeException -> Maybe FlowError
$cfromException :: SomeException -> Maybe FlowError
toException :: FlowError -> SomeException
$ctoException :: FlowError -> SomeException
Exception)

--------------------------------------------------------------------------------
-- | Send the end-user to this URI after setting a cookie.
--
-- The function for generating a cookie accepts the name of the
-- cookie.  This allows you to give the cookie any name you
-- choose.  Just be sure to retrieve the same cookie from the
-- end-user when creating the 'UserReturnFromRedirect' value.
--
-- The returned cookie has all of its security-related features
-- enabled.  Depending on your hosting requirements you may need
-- to use the @cookie@ package to loosen these restrictions.
--
-- Setting (and retrieving) the given cookie is mandatory.  It is
-- used to cryptographically derive the @state@ and @nonce@ values
-- for request forgery protection and replay protection.
data RedirectTo = RedirectTo Network.URI (ByteString -> SetCookie)

--------------------------------------------------------------------------------
-- | __Step 1: Send the end-user to the provider.__
--
-- This request will create a URI pointing to the provider's
-- authorization end point and a session cookie that must be set
-- in the end-user's browser.
--
-- To create a 'Discovery' value, use the
-- 'OpenID.Connect.Client.Provider.discovery' function.
--
-- To create an 'AuthenticationRequest' value use the
-- 'defaultAuthenticationRequest' function.
authenticationRedirect
  :: MonadRandom m
  => Discovery
  -> AuthenticationRequest
  -> m (Either FlowError RedirectTo)
authenticationRedirect :: forall (m :: * -> *).
MonadRandom m =>
Discovery
-> AuthenticationRequest -> m (Either FlowError RedirectTo)
authenticationRedirect Discovery
disco AuthenticationRequest
req = do
  let uri :: ClientRedirectURI
uri = AuthenticationRequest -> ClientRedirectURI
authRequestRedirectURI AuthenticationRequest
req
  Secrets
secrets <- forall (m :: * -> *). MonadRandom m => m Secrets
generateRandomSecrets
  Secrets
-> Discovery
-> AuthenticationRequest
-> Either FlowError ClientRedirectURI
makeRedirectURI Secrets
secrets Discovery
disco AuthenticationRequest
req
    forall a b. a -> (a -> b) -> b
& forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (ClientRedirectURI -> (ByteString -> SetCookie) -> RedirectTo
`RedirectTo` Secrets -> ClientRedirectURI -> ByteString -> SetCookie
makeSessionCookie Secrets
secrets ClientRedirectURI
uri)
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a. Applicative f => a -> f a
pure

--------------------------------------------------------------------------------
-- | __Step 2. Turn the end-user's authorization token into an identity token.__
--
-- When the end-user returns from the provider they will make a
-- request to your site with some query parameters and a session
-- cookie.  With those values in hand, this function represents
-- a request to receive and validate an identity token from the
-- provider.
--
-- In order to create this function you'll need a few records:
--
--   * The current time given as a 'UTCTime'
--   * A 'Provider' record (discovery document and key set)
--   * Your client 'Credentials'
--   * The request details from the end-user in 'UserReturnFromRedirect'
authenticationSuccess
  :: MonadRandom m
  => HTTPS m
  -> UTCTime
  -> Provider
  -> Credentials
  -> UserReturnFromRedirect
  -> m (Either FlowError (TokenResponse ClaimsSet))
authenticationSuccess :: forall (m :: * -> *).
MonadRandom m =>
HTTPS m
-> UTCTime
-> Provider
-> Credentials
-> UserReturnFromRedirect
-> m (Either FlowError (TokenResponse ClaimsSet))
authenticationSuccess HTTPS m
https UTCTime
time Provider
provider Credentials
creds UserReturnFromRedirect
user =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadRandom m =>
HTTPS m
-> UTCTime
-> Provider
-> Credentials
-> UserReturnFromRedirect
-> m (Either FlowError (TokenResponse (ClaimsSet, SignedJWT)))
authenticationSuccessWithJwt HTTPS m
https UTCTime
time Provider
provider Credentials
creds UserReturnFromRedirect
user

-- | Same as 'authenticationSuccess' but return also the original id_token as SignedJWT.
--
-- Some endpoints (e.g. the end_session_endpoint) may require the original
-- id_token; this functions allows an application to save it for later use.
--
-- @since 0.2.0
authenticationSuccessWithJwt
  :: MonadRandom m
  => HTTPS m
  -> UTCTime
  -> Provider
  -> Credentials
  -> UserReturnFromRedirect
  -> m (Either FlowError (TokenResponse (ClaimsSet, SignedJWT)))
authenticationSuccessWithJwt :: forall (m :: * -> *).
MonadRandom m =>
HTTPS m
-> UTCTime
-> Provider
-> Credentials
-> UserReturnFromRedirect
-> m (Either FlowError (TokenResponse (ClaimsSet, SignedJWT)))
authenticationSuccessWithJwt HTTPS m
https UTCTime
time (Provider Discovery
disco JWKSet
keys) Credentials
creds UserReturnFromRedirect
user = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
  ()
_ <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserReturnFromRedirect -> Either FlowError ()
verifyPostRedirectRequest UserReturnFromRedirect
user))
  TokenResponse SignedJWT
token <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (m :: * -> *).
MonadRandom m =>
HTTPS m
-> UTCTime
-> Discovery
-> Credentials
-> UserReturnFromRedirect
-> m (Either FlowError (TokenResponse SignedJWT))
exchangeCodeForIdentityToken HTTPS m
https UTCTime
time Discovery
disco Credentials
creds UserReturnFromRedirect
user)
  forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, forall a. TokenResponse a -> a
idToken TokenResponse SignedJWT
token) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Discovery
-> Credentials
-> TokenResponse SignedJWT
-> JWKSet
-> UTCTime
-> UserReturnFromRedirect
-> Either FlowError (TokenResponse ClaimsSet)
extractClaimsSetFromTokenResponse Discovery
disco Credentials
creds TokenResponse SignedJWT
token JWKSet
keys UTCTime
time UserReturnFromRedirect
user))

--------------------------------------------------------------------------------
-- | Create the provider authorization redirect URI for the end-user.
makeRedirectURI
  :: Secrets
  -> Discovery
  -> AuthenticationRequest
  -> Either FlowError Network.URI
makeRedirectURI :: Secrets
-> Discovery
-> AuthenticationRequest
-> Either FlowError ClientRedirectURI
makeRedirectURI Secrets
secrets Discovery
disco AuthenticationRequest{Query
Maybe Int
Maybe ByteString
Maybe Text
Maybe Words
ByteString
Text
ClientRedirectURI
Scope
authRequestOtherParams :: Query
authRequestAcrValues :: Maybe Words
authRequestLoginHint :: Maybe Text
authRequestIdTokenHint :: Maybe ByteString
authRequestUiLocales :: Maybe Words
authRequestMaxAge :: Maybe Int
authRequestPrompt :: Maybe ByteString
authRequestDisplay :: Maybe ByteString
authRequestResponseType :: ByteString
authRequestScope :: Scope
authRequestClientId :: Text
authRequestRedirectURI :: ClientRedirectURI
authRequestOtherParams :: AuthenticationRequest -> Query
authRequestAcrValues :: AuthenticationRequest -> Maybe Words
authRequestLoginHint :: AuthenticationRequest -> Maybe Text
authRequestIdTokenHint :: AuthenticationRequest -> Maybe ByteString
authRequestUiLocales :: AuthenticationRequest -> Maybe Words
authRequestMaxAge :: AuthenticationRequest -> Maybe Int
authRequestPrompt :: AuthenticationRequest -> Maybe ByteString
authRequestDisplay :: AuthenticationRequest -> Maybe ByteString
authRequestClientId :: AuthenticationRequest -> Text
authRequestResponseType :: AuthenticationRequest -> ByteString
authRequestScope :: AuthenticationRequest -> Scope
authRequestRedirectURI :: AuthenticationRequest -> ClientRedirectURI
..} =
  let uri :: ClientRedirectURI
uri = URI -> ClientRedirectURI
getURI (Discovery -> URI
authorizationEndpoint Discovery
disco)
  in forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ClientRedirectURI
uri
       { uriQuery :: String
Network.uriQuery = ByteString -> String
Char8.unpack
           (Bool -> Query -> ByteString
renderQuery Bool
True (Query
params forall a. Semigroup a => a -> a -> a
<> Query
authRequestOtherParams))
       }

  where
    params :: [QueryItem]
    params :: Query
params = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
      [ (ByteString
"response_type", forall a. a -> Maybe a
Just ByteString
authRequestResponseType)
      , (ByteString
"client_id",     forall a. a -> Maybe a
Just (Text -> ByteString
Text.encodeUtf8 Text
authRequestClientId))
      , (ByteString
"redirect_uri",  forall a. a -> Maybe a
Just ByteString
redir)
      , (ByteString
"nonce",         forall a. a -> Maybe a
Just (Secrets -> ByteString
replayProtectionNonce Secrets
secrets))
      , (ByteString
"state",         forall a. a -> Maybe a
Just (Secrets -> ByteString
requestForgeryProtectionToken Secrets
secrets))
      , (ByteString
"display",       Maybe ByteString
authRequestDisplay)
      , (ByteString
"prompt",        Maybe ByteString
authRequestPrompt)
      , (ByteString
"max_age",       String -> ByteString
Char8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
authRequestMaxAge)
      , (ByteString
"ui_locales",    Text -> ByteString
Text.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Words -> Text
fromWords forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Words
authRequestUiLocales)
      , (ByteString
"id_token_hint", Maybe ByteString
authRequestIdTokenHint)
      , (ByteString
"login_hint",    Text -> ByteString
Text.encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
authRequestLoginHint)
      , (ByteString
"acr_values",    Text -> ByteString
Text.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Words -> Text
fromWords forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Words
authRequestAcrValues)
      , Scope -> QueryItem
scopeQueryItem    Scope
authRequestScope
      ]

    redir :: ByteString
    redir :: ByteString
redir = String -> ByteString
Char8.pack (ShowS -> ClientRedirectURI -> ShowS
Network.uriToString forall a. a -> a
id ClientRedirectURI
authRequestRedirectURI [])

--------------------------------------------------------------------------------
-- | Create a session cookie for the end-user.
makeSessionCookie :: Secrets -> ClientRedirectURI -> ByteString -> SetCookie
makeSessionCookie :: Secrets -> ClientRedirectURI -> ByteString -> SetCookie
makeSessionCookie Secrets{ByteString
valueForHttpOnlyCookie :: ByteString
valueForHttpOnlyCookie :: Secrets -> ByteString
valueForHttpOnlyCookie} ClientRedirectURI
uri ByteString
name =
  SetCookie
Cookie.defaultSetCookie
    { setCookieName :: ByteString
Cookie.setCookieName     = ByteString
name
    , setCookieValue :: ByteString
Cookie.setCookieValue    = ByteString
valueForHttpOnlyCookie
    , setCookiePath :: Maybe ByteString
Cookie.setCookiePath     = forall a. a -> Maybe a
Just (String -> ByteString
Char8.pack (ClientRedirectURI -> String
Network.uriPath ClientRedirectURI
uri))
    , setCookieHttpOnly :: Bool
Cookie.setCookieHttpOnly = Bool
True
    , setCookieSecure :: Bool
Cookie.setCookieSecure   = Bool
True
    , setCookieSameSite :: Maybe SameSiteOption
Cookie.setCookieSameSite = forall a. a -> Maybe a
Just SameSiteOption
Cookie.sameSiteLax
    }

--------------------------------------------------------------------------------
-- | Validate the @state@ parameter from the end-user.
verifyPostRedirectRequest :: UserReturnFromRedirect -> Either FlowError ()
verifyPostRedirectRequest :: UserReturnFromRedirect -> Either FlowError ()
verifyPostRedirectRequest UserReturnFromRedirect{ByteString
afterRedirectStateParam :: ByteString
afterRedirectCodeParam :: ByteString
afterRedirectSessionCookie :: ByteString
afterRedirectStateParam :: UserReturnFromRedirect -> ByteString
afterRedirectCodeParam :: UserReturnFromRedirect -> ByteString
afterRedirectSessionCookie :: UserReturnFromRedirect -> ByteString
..} = do
  ByteString
expectState <- ByteString -> Either FlowError ByteString
expectedStateParam ByteString
afterRedirectSessionCookie
  if ByteString
afterRedirectStateParam forall a. Eq a => a -> a -> Bool
== ByteString
expectState
    then forall a b. b -> Either a b
Right ()
    else forall a b. a -> Either a b
Left FlowError
InvalidStateParameterError

--------------------------------------------------------------------------------
-- | Use HTTP to exchange an access token for an identity token.
exchangeCodeForIdentityToken
  :: forall m. MonadRandom m
  => HTTPS m
  -> UTCTime
  -> Discovery
  -> Credentials
  -> UserReturnFromRedirect
  -> m (Either FlowError (TokenResponse SignedJWT))
exchangeCodeForIdentityToken :: forall (m :: * -> *).
MonadRandom m =>
HTTPS m
-> UTCTime
-> Discovery
-> Credentials
-> UserReturnFromRedirect
-> m (Either FlowError (TokenResponse SignedJWT))
exchangeCodeForIdentityToken HTTPS m
https UTCTime
now Discovery
disco Credentials
creds UserReturnFromRedirect
user = do
    Either FlowError (Response ByteString)
res <- m (Either FlowError (Response ByteString))
performRequest
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response ByteString -> Either FlowError (TokenResponse SignedJWT)
processResponse forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either FlowError (Response ByteString)
res)
  where
    performRequest :: m (Either FlowError (HTTP.Response LByteString.ByteString))
    performRequest :: m (Either FlowError (Response ByteString))
performRequest = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
      URI
uri <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FlowError
ProviderMissingTokenEndpointError) forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Discovery -> Maybe URI
tokenEndpoint Discovery
disco)
      Request
req <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> FlowError
InvalidProviderTokenEndpointError (ClientRedirectURI -> Text
uriToText (URI -> ClientRedirectURI
getURI URI
uri)))) forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either Text ClientRedirectURI -> Maybe Request
requestFromURI (forall a b. b -> Either a b
Right (URI -> ClientRedirectURI
getURI URI
uri)))
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *).
MonadRandom m =>
Credentials
-> [ClientAuthentication]
-> URI
-> UTCTime
-> [(ByteString, ByteString)]
-> Request
-> m (Maybe Request)
applyRequestAuthentication Credentials
creds [ClientAuthentication]
authMethods URI
uri UTCTime
now [(ByteString, ByteString)]
body Request
req) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Request
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FlowError
NoAuthenticationMethodsAvailableError
        Just Request
r  -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (HTTPS m
https Request
r)

    processResponse
      :: HTTP.Response LByteString.ByteString
      -> Either FlowError (TokenResponse SignedJWT)
    processResponse :: Response ByteString -> Either FlowError (TokenResponse SignedJWT)
processResponse Response ByteString
res =
      forall a.
FromJSON a =>
Response ByteString -> Either ErrorResponse (a, Maybe UTCTime)
parseResponse Response ByteString
res
      forall a b. a -> (a -> b) -> b
& forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ErrorResponse -> FlowError
InvalidProviderTokenResponseError forall a b. (a, b) -> a
fst
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TokenResponse Text -> Either Error (TokenResponse SignedJWT)
decodeIdentityToken forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Error -> FlowError
TokenDecodingError)

    authMethods :: [ClientAuthentication]
    authMethods :: [ClientAuthentication]
authMethods = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [ClientAuthentication
ClientSecretPost] forall a. NonEmpty a -> [a]
NonEmpty.toList
      (Discovery -> Maybe (NonEmpty ClientAuthentication)
tokenEndpointAuthMethodsSupported Discovery
disco)

    body :: [ (ByteString, ByteString) ]
    body :: [(ByteString, ByteString)]
body  = [ (ByteString
"grant_type", ByteString
"authorization_code")
            , (ByteString
"code", UserReturnFromRedirect -> ByteString
afterRedirectCodeParam UserReturnFromRedirect
user)
            , (ByteString
"redirect_uri", String -> ByteString
Char8.pack (ShowS -> ClientRedirectURI -> ShowS
Network.uriToString forall a. a -> a
id (Credentials -> ClientRedirectURI
clientRedirectUri Credentials
creds) []))
            , (ByteString
"client_id", Text -> ByteString
Text.encodeUtf8 (Credentials -> Text
assignedClientId Credentials
creds))
            ]

--------------------------------------------------------------------------------
-- | Verify an identity token and then expose the claims it holds.
extractClaimsSetFromTokenResponse
  :: Discovery
  -> Credentials
  -> TokenResponse SignedJWT
  -> JWKSet
  -> UTCTime
  -> UserReturnFromRedirect
  -> Either FlowError (TokenResponse ClaimsSet)
extractClaimsSetFromTokenResponse :: Discovery
-> Credentials
-> TokenResponse SignedJWT
-> JWKSet
-> UTCTime
-> UserReturnFromRedirect
-> Either FlowError (TokenResponse ClaimsSet)
extractClaimsSetFromTokenResponse Discovery
disco Credentials
creds TokenResponse SignedJWT
token JWKSet
keys UTCTime
time UserReturnFromRedirect
user = do
  Text
nonce <- ByteString -> Either FlowError Text
expectedNonce (UserReturnFromRedirect -> ByteString
afterRedirectSessionCookie UserReturnFromRedirect
user)
  Discovery
-> Text
-> UTCTime
-> JWKSet
-> Text
-> TokenResponse SignedJWT
-> Either JWTError (TokenResponse ClaimsSet)
verifyIdentityTokenClaims Discovery
disco (Credentials -> Text
assignedClientId Credentials
creds) UTCTime
time JWKSet
keys Text
nonce TokenResponse SignedJWT
token
   forall a b. a -> (a -> b) -> b
& forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first JWTError -> FlowError
IdentityTokenValidationFailed