{-|

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
  , 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)
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 :: m Secrets
generateRandomSecrets = do
  ByteString
bytes <- Int -> m ByteString
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
64 :: m ByteString
  let hash1 :: Digest SHA256
hash1 = ByteString -> Digest SHA256
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 = ByteString -> Digest SHA256
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

  Secrets -> m Secrets
forall (f :: * -> *) a. Applicative f => a -> f a
pure Secrets :: ByteString -> ByteString -> ByteString -> Secrets
Secrets
    { requestForgeryProtectionToken :: ByteString
requestForgeryProtectionToken = Base -> Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded Digest SHA256
hash2
    , replayProtectionNonce :: ByteString
replayProtectionNonce         = Base -> Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded Digest SHA256
hash1
    , valueForHttpOnlyCookie :: ByteString
valueForHttpOnlyCookie        = Base -> ByteString -> ByteString
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)
  Either String ByteString
-> (Either String ByteString -> Either FlowError ByteString)
-> Either FlowError ByteString
forall a b. a -> (a -> b) -> b
& (String -> FlowError)
-> Either String ByteString -> Either FlowError ByteString
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FlowError -> String -> FlowError
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)
  Either String ByteString
-> (Either String ByteString -> Either FlowError Text)
-> Either FlowError Text
forall a b. a -> (a -> b) -> b
& (String -> FlowError)
-> (ByteString -> Text)
-> Either String ByteString
-> Either FlowError Text
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (FlowError -> String -> FlowError
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 =
    Base -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64URLUnpadded ByteString
cookie Either String ByteString
-> (ByteString -> ByteString) -> Either String ByteString
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> ByteString
rehash (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
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 = ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash ByteString
bs :: Hash.Digest Hash.SHA256
                in Base -> Digest SHA256 -> ByteString
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 :: ClientRedirectURI
-> Text
-> Scope
-> ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Maybe Int
-> Maybe Words
-> Maybe ByteString
-> Maybe Text
-> Maybe Words
-> [QueryItem]
-> AuthenticationRequest
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      = Maybe ByteString
forall a. Maybe a
Nothing
    , authRequestPrompt :: Maybe ByteString
authRequestPrompt       = Maybe ByteString
forall a. Maybe a
Nothing
    , authRequestMaxAge :: Maybe Int
authRequestMaxAge       = Maybe Int
forall a. Maybe a
Nothing
    , authRequestUiLocales :: Maybe Words
authRequestUiLocales    = Maybe Words
forall a. Maybe a
Nothing
    , authRequestIdTokenHint :: Maybe ByteString
authRequestIdTokenHint  = Maybe ByteString
forall a. Maybe a
Nothing
    , authRequestLoginHint :: Maybe Text
authRequestLoginHint    = Maybe Text
forall a. Maybe a
Nothing
    , authRequestAcrValues :: Maybe Words
authRequestAcrValues    = Maybe Words
forall a. Maybe a
Nothing
    , authRequestOtherParams :: [QueryItem]
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
(Int -> FlowError -> ShowS)
-> (FlowError -> String)
-> ([FlowError] -> ShowS)
-> Show FlowError
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
Typeable FlowError
-> Show FlowError
-> (FlowError -> SomeException)
-> (SomeException -> Maybe FlowError)
-> (FlowError -> String)
-> Exception 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
$cp2Exception :: Show FlowError
$cp1Exception :: Typeable FlowError
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 :: Discovery
-> AuthenticationRequest -> m (Either FlowError RedirectTo)
authenticationRedirect Discovery
disco AuthenticationRequest
req = do
  let uri :: ClientRedirectURI
uri = AuthenticationRequest -> ClientRedirectURI
authRequestRedirectURI AuthenticationRequest
req
  Secrets
secrets <- m Secrets
forall (m :: * -> *). MonadRandom m => m Secrets
generateRandomSecrets
  Secrets
-> Discovery
-> AuthenticationRequest
-> Either FlowError ClientRedirectURI
makeRedirectURI Secrets
secrets Discovery
disco AuthenticationRequest
req
    Either FlowError ClientRedirectURI
-> (Either FlowError ClientRedirectURI
    -> Either FlowError RedirectTo)
-> Either FlowError RedirectTo
forall a b. a -> (a -> b) -> b
& (ClientRedirectURI -> RedirectTo)
-> Either FlowError ClientRedirectURI
-> Either FlowError RedirectTo
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)
    Either FlowError RedirectTo
-> (Either FlowError RedirectTo -> m (Either FlowError RedirectTo))
-> m (Either FlowError RedirectTo)
forall a b. a -> (a -> b) -> b
& Either FlowError RedirectTo -> m (Either FlowError RedirectTo)
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 :: HTTPS m
-> UTCTime
-> Provider
-> Credentials
-> UserReturnFromRedirect
-> m (Either FlowError (TokenResponse ClaimsSet))
authenticationSuccess HTTPS m
https UTCTime
time (Provider Discovery
disco JWKSet
keys) Credentials
creds UserReturnFromRedirect
user = ExceptT FlowError m (TokenResponse ClaimsSet)
-> m (Either FlowError (TokenResponse ClaimsSet))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT FlowError m (TokenResponse ClaimsSet)
 -> m (Either FlowError (TokenResponse ClaimsSet)))
-> ExceptT FlowError m (TokenResponse ClaimsSet)
-> m (Either FlowError (TokenResponse ClaimsSet))
forall a b. (a -> b) -> a -> b
$ do
  ()
_ <- m (Either FlowError ()) -> ExceptT FlowError m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either FlowError () -> m (Either FlowError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserReturnFromRedirect -> Either FlowError ()
verifyPostRedirectRequest UserReturnFromRedirect
user))
  TokenResponse SignedJWT
token <- m (Either FlowError (TokenResponse SignedJWT))
-> ExceptT FlowError m (TokenResponse SignedJWT)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (HTTPS m
-> UTCTime
-> Discovery
-> Credentials
-> UserReturnFromRedirect
-> m (Either FlowError (TokenResponse SignedJWT))
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)
  m (Either FlowError (TokenResponse ClaimsSet))
-> ExceptT FlowError m (TokenResponse ClaimsSet)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either FlowError (TokenResponse ClaimsSet)
-> m (Either FlowError (TokenResponse ClaimsSet))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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{[QueryItem]
Maybe Int
Maybe ByteString
Maybe Text
Maybe Words
ByteString
Text
ClientRedirectURI
Scope
authRequestOtherParams :: [QueryItem]
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 -> [QueryItem]
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 ClientRedirectURI -> Either FlowError ClientRedirectURI
forall a b. b -> Either a b
Right (ClientRedirectURI -> Either FlowError ClientRedirectURI)
-> ClientRedirectURI -> Either FlowError ClientRedirectURI
forall a b. (a -> b) -> a -> b
$ ClientRedirectURI
uri
       { uriQuery :: String
Network.uriQuery = ByteString -> String
Char8.unpack
           (Bool -> [QueryItem] -> ByteString
renderQuery Bool
True ([QueryItem]
params [QueryItem] -> [QueryItem] -> [QueryItem]
forall a. Semigroup a => a -> a -> a
<> [QueryItem]
authRequestOtherParams))
       }

  where
    params :: [QueryItem]
    params :: [QueryItem]
params = (QueryItem -> Bool) -> [QueryItem] -> [QueryItem]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool)
-> (QueryItem -> Maybe ByteString) -> QueryItem -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryItem -> Maybe ByteString
forall a b. (a, b) -> b
snd)
      [ (ByteString
"response_type", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
authRequestResponseType)
      , (ByteString
"client_id",     ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
Text.encodeUtf8 Text
authRequestClientId))
      , (ByteString
"redirect_uri",  ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
redir)
      , (ByteString
"nonce",         ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Secrets -> ByteString
replayProtectionNonce Secrets
secrets))
      , (ByteString
"state",         ByteString -> Maybe ByteString
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 (String -> ByteString) -> (Int -> String) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> ByteString) -> Maybe Int -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
authRequestMaxAge)
      , (ByteString
"ui_locales",    Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> (Words -> Text) -> Words -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Words -> Text
fromWords (Words -> ByteString) -> Maybe Words -> Maybe ByteString
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 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
authRequestLoginHint)
      , (ByteString
"acr_values",    Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> (Words -> Text) -> Words -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Words -> Text
fromWords (Words -> ByteString) -> Maybe Words -> Maybe ByteString
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 ShowS
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     = ByteString -> Maybe ByteString
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 = SameSiteOption -> Maybe SameSiteOption
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
expectState
    then () -> Either FlowError ()
forall a b. b -> Either a b
Right ()
    else FlowError -> Either FlowError ()
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 :: 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
    Either FlowError (TokenResponse SignedJWT)
-> m (Either FlowError (TokenResponse SignedJWT))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response ByteString -> Either FlowError (TokenResponse SignedJWT)
processResponse (Response ByteString -> Either FlowError (TokenResponse SignedJWT))
-> Either FlowError (Response ByteString)
-> Either FlowError (TokenResponse SignedJWT)
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 = ExceptT FlowError m (Response ByteString)
-> m (Either FlowError (Response ByteString))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT FlowError m (Response ByteString)
 -> m (Either FlowError (Response ByteString)))
-> ExceptT FlowError m (Response ByteString)
-> m (Either FlowError (Response ByteString))
forall a b. (a -> b) -> a -> b
$ do
      URI
uri <- ExceptT FlowError m URI
-> (URI -> ExceptT FlowError m URI)
-> Maybe URI
-> ExceptT FlowError m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (FlowError -> ExceptT FlowError m URI
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FlowError
ProviderMissingTokenEndpointError) URI -> ExceptT FlowError m URI
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Discovery -> Maybe URI
tokenEndpoint Discovery
disco)
      Request
req <- ExceptT FlowError m Request
-> (Request -> ExceptT FlowError m Request)
-> Maybe Request
-> ExceptT FlowError m Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (FlowError -> ExceptT FlowError m Request
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> FlowError
InvalidProviderTokenEndpointError (ClientRedirectURI -> Text
uriToText (URI -> ClientRedirectURI
getURI URI
uri)))) Request -> ExceptT FlowError m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either Text ClientRedirectURI -> Maybe Request
requestFromURI (ClientRedirectURI -> Either Text ClientRedirectURI
forall a b. b -> Either a b
Right (URI -> ClientRedirectURI
getURI URI
uri)))
      Credentials
-> [ClientAuthentication]
-> URI
-> UTCTime
-> [(ByteString, ByteString)]
-> Request
-> ExceptT FlowError m (Maybe Request)
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 ExceptT FlowError m (Maybe Request)
-> (Maybe Request -> ExceptT FlowError m (Response ByteString))
-> ExceptT FlowError m (Response ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe Request
Nothing -> FlowError -> ExceptT FlowError m (Response ByteString)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FlowError
NoAuthenticationMethodsAvailableError
          Just Request
r  -> m (Response ByteString)
-> ExceptT FlowError m (Response ByteString)
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 =
      Response ByteString
-> Either ErrorResponse (TokenResponse Text, Maybe UTCTime)
forall a.
FromJSON a =>
Response ByteString -> Either ErrorResponse (a, Maybe UTCTime)
parseResponse Response ByteString
res
      Either ErrorResponse (TokenResponse Text, Maybe UTCTime)
-> (Either ErrorResponse (TokenResponse Text, Maybe UTCTime)
    -> Either FlowError (TokenResponse Text))
-> Either FlowError (TokenResponse Text)
forall a b. a -> (a -> b) -> b
& (ErrorResponse -> FlowError)
-> ((TokenResponse Text, Maybe UTCTime) -> TokenResponse Text)
-> Either ErrorResponse (TokenResponse Text, Maybe UTCTime)
-> Either FlowError (TokenResponse Text)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ErrorResponse -> FlowError
InvalidProviderTokenResponseError (TokenResponse Text, Maybe UTCTime) -> TokenResponse Text
forall a b. (a, b) -> a
fst
      Either FlowError (TokenResponse Text)
-> (TokenResponse Text
    -> Either FlowError (TokenResponse SignedJWT))
-> Either FlowError (TokenResponse SignedJWT)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TokenResponse Text -> Either Error (TokenResponse SignedJWT)
decodeIdentityToken (TokenResponse Text -> Either Error (TokenResponse SignedJWT))
-> (Either Error (TokenResponse SignedJWT)
    -> Either FlowError (TokenResponse SignedJWT))
-> TokenResponse Text
-> Either FlowError (TokenResponse SignedJWT)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Error -> FlowError)
-> Either Error (TokenResponse SignedJWT)
-> Either FlowError (TokenResponse SignedJWT)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Error -> FlowError
TokenDecodingError)

    authMethods :: [ClientAuthentication]
    authMethods :: [ClientAuthentication]
authMethods = [ClientAuthentication]
-> (NonEmpty ClientAuthentication -> [ClientAuthentication])
-> Maybe (NonEmpty ClientAuthentication)
-> [ClientAuthentication]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [ClientAuthentication
ClientSecretPost] NonEmpty ClientAuthentication -> [ClientAuthentication]
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 ShowS
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
   Either JWTError (TokenResponse ClaimsSet)
-> (Either JWTError (TokenResponse ClaimsSet)
    -> Either FlowError (TokenResponse ClaimsSet))
-> Either FlowError (TokenResponse ClaimsSet)
forall a b. a -> (a -> b) -> b
& (JWTError -> FlowError)
-> Either JWTError (TokenResponse ClaimsSet)
-> Either FlowError (TokenResponse ClaimsSet)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first JWTError -> FlowError
IdentityTokenValidationFailed