{-# LANGUAGE OverloadedStrings #-}
module Web.OIDC.Client.IdTokenFlow
(
getAuthenticationRequestUrl
, getValidIdTokenClaims
, prepareAuthenticationRequestUrl
) where
import Control.Monad (when)
import Control.Exception (throwIO, catch)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (FromJSON)
import qualified Data.ByteString.Char8 as B
import Data.List (nub)
import Data.Maybe (isNothing, fromMaybe)
import Data.Monoid ((<>))
import Data.Text (unpack)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Jose.Jwt as Jwt
import Network.HTTP.Client (getUri, setQueryString)
import Network.URI (URI)
import Prelude hiding (exp)
import Web.OIDC.Client.Internal (parseUrl)
import qualified Web.OIDC.Client.Internal as I
import Web.OIDC.Client.Settings (OIDC (..))
import Web.OIDC.Client.Tokens (IdTokenClaims (..), validateIdToken)
import Web.OIDC.Client.Types (OpenIdException (..),
Parameters, Scope,
SessionStore (..), State,
openId)
prepareAuthenticationRequestUrl
:: (MonadIO m)
=> SessionStore m
-> OIDC
-> Scope
-> Parameters
-> m URI
prepareAuthenticationRequestUrl :: forall (m :: * -> *).
MonadIO m =>
SessionStore m -> OIDC -> Scope -> Parameters -> m URI
prepareAuthenticationRequestUrl SessionStore m
store OIDC
oidc Scope
scope Parameters
params = do
ByteString
state <- SessionStore m -> m ByteString
forall (m :: * -> *). SessionStore m -> m ByteString
sessionStoreGenerate SessionStore m
store
ByteString
nonce' <- SessionStore m -> m ByteString
forall (m :: * -> *). SessionStore m -> m ByteString
sessionStoreGenerate SessionStore m
store
SessionStore m -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
SessionStore m -> ByteString -> ByteString -> m ()
sessionStoreSave SessionStore m
store ByteString
state ByteString
nonce'
OIDC -> Scope -> Maybe ByteString -> Parameters -> m URI
forall (m :: * -> *).
MonadIO m =>
OIDC -> Scope -> Maybe ByteString -> Parameters -> m URI
getAuthenticationRequestUrl OIDC
oidc Scope
scope (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
state) (Parameters -> m URI) -> Parameters -> m URI
forall a b. (a -> b) -> a -> b
$ Parameters
params Parameters -> Parameters -> Parameters
forall a. [a] -> [a] -> [a]
++ [(ByteString
"nonce", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
nonce')]
getValidIdTokenClaims
:: (MonadIO m, FromJSON a)
=> SessionStore m
-> OIDC
-> State
-> m B.ByteString
-> m (IdTokenClaims a)
getValidIdTokenClaims :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
SessionStore m
-> OIDC -> ByteString -> m ByteString -> m (IdTokenClaims a)
getValidIdTokenClaims SessionStore m
store OIDC
oidc ByteString
stateFromIdP m ByteString
getIdToken = do
Maybe ByteString
msavedNonce <- SessionStore m -> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
SessionStore m -> ByteString -> m (Maybe ByteString)
sessionStoreGet SessionStore m
store ByteString
stateFromIdP
ByteString
savedNonce <- m ByteString
-> (ByteString -> m ByteString) -> Maybe ByteString -> m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ OpenIdException -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO OpenIdException
UnknownState) ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
msavedNonce
Jwt
jwt <- ByteString -> Jwt
Jwt.Jwt (ByteString -> Jwt) -> m ByteString -> m Jwt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ByteString
getIdToken
SessionStore m -> m ()
forall (m :: * -> *). SessionStore m -> m ()
sessionStoreDelete SessionStore m
store
IdTokenClaims a
idToken <- IO (IdTokenClaims a) -> m (IdTokenClaims a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IdTokenClaims a) -> m (IdTokenClaims a))
-> IO (IdTokenClaims a) -> m (IdTokenClaims a)
forall a b. (a -> b) -> a -> b
$ OIDC -> Jwt -> IO (IdTokenClaims a)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
OIDC -> Jwt -> m (IdTokenClaims a)
validateIdToken OIDC
oidc Jwt
jwt
ByteString
nonce' <- m ByteString
-> (ByteString -> m ByteString) -> Maybe ByteString -> m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ OpenIdException -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO OpenIdException
MissingNonceInResponse) ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdTokenClaims a -> Maybe ByteString
forall a. IdTokenClaims a -> Maybe ByteString
nonce IdTokenClaims a
idToken)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
nonce' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
savedNonce) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ OpenIdException -> IO ()
forall e a. Exception e => e -> IO a
throwIO OpenIdException
MismatchedNonces
IdTokenClaims a -> m (IdTokenClaims a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IdTokenClaims a
idToken
{-# WARNING getAuthenticationRequestUrl "This function doesn't manage state and nonce. Use prepareAuthenticationRequestUrl only unless your IdP doesn't support state and/or nonce." #-}
getAuthenticationRequestUrl
:: (MonadIO m)
=> OIDC
-> Scope
-> Maybe State
-> Parameters
-> m URI
getAuthenticationRequestUrl :: forall (m :: * -> *).
MonadIO m =>
OIDC -> Scope -> Maybe ByteString -> Parameters -> m URI
getAuthenticationRequestUrl OIDC
oidc Scope
scope Maybe ByteString
state Parameters
params = do
Request
req <- IO Request -> m Request
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ Text -> IO Request
forall (m :: * -> *). MonadThrow m => Text -> m Request
parseUrl Text
endpoint IO Request -> (HttpException -> IO Request) -> IO Request
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` HttpException -> IO Request
forall (m :: * -> *) a. MonadCatch m => HttpException -> m a
I.rethrow
URI -> m URI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> m URI) -> URI -> m URI
forall a b. (a -> b) -> a -> b
$ Request -> URI
getUri (Request -> URI) -> Request -> URI
forall a b. (a -> b) -> a -> b
$ Parameters -> Request -> Request
setQueryString Parameters
query Request
req
where
endpoint :: Text
endpoint = OIDC -> Text
oidcAuthorizationServerUrl OIDC
oidc
query :: Parameters
query = Parameters
requireds Parameters -> Parameters -> Parameters
forall a. [a] -> [a] -> [a]
++ Parameters
state' Parameters -> Parameters -> Parameters
forall a. [a] -> [a] -> [a]
++ Parameters
params
requireds :: Parameters
requireds =
[ (ByteString
"response_type", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"id_token")
, (ByteString
"response_mode", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"form_post")
, (ByteString
"client_id", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ OIDC -> ByteString
oidcClientId OIDC
oidc)
, (ByteString
"redirect_uri", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ OIDC -> ByteString
oidcRedirectUri OIDC
oidc)
, (ByteString
"scope", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Scope -> ByteString) -> Scope -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack (String -> ByteString) -> (Scope -> String) -> Scope -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> String) -> (Scope -> [String]) -> Scope -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> (Scope -> [String]) -> Scope -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String) -> Scope -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack (Scope -> Maybe ByteString) -> Scope -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text
openIdText -> Scope -> Scope
forall a. a -> [a] -> [a]
:Scope
scope)
]
state' :: Parameters
state' =
case Maybe ByteString
state of
Just ByteString
_ -> [(ByteString
"state", Maybe ByteString
state)]
Maybe ByteString
Nothing -> []