diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,14 @@ # ChangeLog -## [Unreleased] +## [0.5.0.0] +### Added +- Add implicit id_token flow. See [#34](https://github.com/krdlab/haskell-oidc-client/pull/34). -Nothing yet. +### Changed +- discover: Append well-known part to parsed request. See [#33](https://github.com/krdlab/haskell-oidc-client/pull/33). + +### Fixed +- Fix unsupported algorithm error. See [#36](https://github.com/krdlab/haskell-oidc-client/pull/36). ## [0.4.0.1] ### Fixed diff --git a/oidc-client.cabal b/oidc-client.cabal --- a/oidc-client.cabal +++ b/oidc-client.cabal @@ -1,5 +1,5 @@ name: oidc-client -version: 0.4.0.1 +version: 0.5.0.0 synopsis: OpenID Connect 1.0 library for RP homepage: https://github.com/krdlab/haskell-oidc-client stability: experimental @@ -35,6 +35,7 @@ exposed-modules: Web.OIDC.Client , Web.OIDC.Client.CodeFlow + , Web.OIDC.Client.IdTokenFlow , Web.OIDC.Client.Discovery , Web.OIDC.Client.Discovery.Issuers , Web.OIDC.Client.Discovery.Provider diff --git a/src/Web/OIDC/Client/CodeFlow.hs b/src/Web/OIDC/Client/CodeFlow.hs --- a/src/Web/OIDC/Client/CodeFlow.hs +++ b/src/Web/OIDC/Client/CodeFlow.hs @@ -22,15 +22,12 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson (FromJSON, eitherDecode) import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Either (partitionEithers) import Data.List (nub) import Data.Maybe (isNothing) import Data.Monoid ((<>)) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock.POSIX (getPOSIXTime) -import Jose.Jwt (Jwt, JwtContent (Jwe, Jws, Unsecured)) import qualified Jose.Jwt as Jwt import Network.HTTP.Client (Manager, Request (..), getUri, httpLbs, @@ -45,7 +42,7 @@ 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 (..), +import Web.OIDC.Client.Tokens (IdTokenClaims (..), validateIdToken, Tokens (..)) import Web.OIDC.Client.Types (Code, Nonce, OpenIdException (..), @@ -164,33 +161,6 @@ , expiresIn = I.expiresIn tres , refreshToken = I.refreshToken tres } - -validateIdToken :: FromJSON a => OIDC -> Jwt -> IO (IdTokenClaims a) -validateIdToken oidc jwt' = do - let jwks = P.jwkSet . oidcProvider $ oidc - token = Jwt.unJwt jwt' - alg = fmap (Jwt.JwsEncoding . P.getJwsAlg) - . P.idTokenSigningAlgValuesSupported - . P.configuration - $ oidcProvider oidc - decoded <- - (\x -> case partitionEithers x of - (_ , k : _) -> Right k - (e : _, _ ) -> Left e - ([] , [] ) -> Left $ Jwt.KeyError "No Keys available for decoding" - ) - <$> traverse (\alg' -> Jwt.decode jwks (Just alg') token) alg - case decoded of - Right (Unsecured payload) -> throwM $ UnsecuredJwt payload - Right (Jws (_header, payload)) -> parsePayload payload - Right (Jwe (_header, payload)) -> parsePayload payload - Left err -> throwM $ JwtExceptoin err - - where - parsePayload payload = - case eitherDecode $ BL.fromStrict payload of - Right x -> return x - Left err -> throwM . JsonException $ pack err validateClaims :: Text -> Text -> Jwt.IntDate -> Maybe Nonce -> IdTokenClaims a -> IO () validateClaims issuer' clientId' now savedNonce claims' = do diff --git a/src/Web/OIDC/Client/Discovery.hs b/src/Web/OIDC/Client/Discovery.hs --- a/src/Web/OIDC/Client/Discovery.hs +++ b/src/Web/OIDC/Client/Discovery.hs @@ -17,10 +17,11 @@ ) where import Control.Monad.Catch (catch, throwM) -import Data.Aeson (decode) -import Data.Text (append) +import Data.Aeson (eitherDecode) +import Data.ByteString (append) +import Data.Text (pack) import qualified Jose.Jwk as Jwk -import Network.HTTP.Client (Manager, httpLbs, +import Network.HTTP.Client (Manager, httpLbs, path, responseBody) import Web.OIDC.Client.Discovery.Issuers (google) @@ -38,19 +39,24 @@ discover location manager = do conf <- getConfiguration `catch` rethrow case conf of - Just c -> Provider c . jwks <$> getJwkSetJson (jwksUri c) `catch` rethrow - Nothing -> throwM $ DiscoveryException "failed to decode configuration" + Right c -> do + json <- getJwkSetJson (jwksUri c) `catch` rethrow + case jwks json of + Right keys -> return $ Provider c keys + Left err -> throwM $ DiscoveryException ("Failed to decode JwkSet: " <> pack err) + Left err -> throwM $ DiscoveryException ("Failed to decode configuration: " <> pack err) where + appendPath suffix req = req { path = path req `append` suffix } + getConfiguration = do - req <- parseUrl (location `append` "/.well-known/openid-configuration") - res <- httpLbs req manager - return $ decode $ responseBody res + req <- parseUrl location + let req' = appendPath "/.well-known/openid-configuration" req + res <- httpLbs req' manager + return $ eitherDecode $ responseBody res + getJwkSetJson url = do req <- parseUrl url res <- httpLbs req manager return $ responseBody res - jwks j = maybe single Jwk.keys (decode j) - where - single = case decode j of - Just k -> return k - Nothing -> mempty + + jwks j = Jwk.keys <$> eitherDecode j diff --git a/src/Web/OIDC/Client/Discovery/Provider.hs b/src/Web/OIDC/Client/Discovery/Provider.hs --- a/src/Web/OIDC/Client/Discovery/Provider.hs +++ b/src/Web/OIDC/Client/Discovery/Provider.hs @@ -17,8 +17,7 @@ import Data.Aeson.TH (Options (..), defaultOptions, deriveFromJSON) import Data.Aeson.Types (camelTo2) -import Data.Monoid ((<>)) -import Data.Text (Text, unpack) +import Data.Text (Text) import Jose.Jwa (JwsAlg (..)) import Jose.Jwk (Jwk) @@ -27,7 +26,7 @@ -- | An OpenID Provider information data Provider = Provider { configuration :: Configuration, jwkSet :: [Jwk] } -newtype JwsAlgJson = JwsAlgJson { getJwsAlg :: JwsAlg } deriving (Show, Eq) +data JwsAlgJson = JwsAlgJson { getJwsAlg :: JwsAlg } | Unsupported Text deriving (Show, Eq) instance FromJSON JwsAlgJson where parseJSON = withText "JwsAlgJson" $ \case @@ -41,7 +40,7 @@ "ES384" -> pure $ JwsAlgJson ES384 "ES512" -> pure $ JwsAlgJson ES512 "none" -> pure $ JwsAlgJson None - other -> fail $ "Non-supported alg: " <> show (unpack other) + other -> pure $ Unsupported other -- | An OpenID Provider Configuration diff --git a/src/Web/OIDC/Client/IdTokenFlow.hs b/src/Web/OIDC/Client/IdTokenFlow.hs new file mode 100644 --- /dev/null +++ b/src/Web/OIDC/Client/IdTokenFlow.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| + Module: Web.OIDC.Client.CodeFlow + Maintainer: krdlab@gmail.com + Stability: experimental +-} +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 (decodeUtf8) +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) + +-- | Make URL for Authorization Request after generating state and nonce from 'SessionStore'. +prepareAuthenticationRequestUrl + :: (MonadIO m) + => SessionStore m + -> OIDC + -> Scope -- ^ used to specify what are privileges requested for tokens. (use `ScopeValue`) + -> Parameters -- ^ Optional parameters + -> m URI +prepareAuthenticationRequestUrl store oidc scope params = do + state <- sessionStoreGenerate store + nonce' <- sessionStoreGenerate store + sessionStoreSave store state nonce' + getAuthenticationRequestUrl oidc scope (Just state) $ params ++ [("nonce", Just nonce')] + +-- | Get and validate access token and with code and state stored in the 'SessionStore'. +-- Then deletes session info by 'sessionStoreDelete'. +getValidIdTokenClaims + :: (MonadIO m, FromJSON a) + => SessionStore m + -> OIDC + -> State + -> m B.ByteString + -> m (IdTokenClaims a) +getValidIdTokenClaims store oidc stateFromIdP getIdToken = do + (state, savedNonce) <- sessionStoreGet store + if state == Just stateFromIdP + then do + when (isNothing savedNonce) $ liftIO $ throwIO $ ValidationException "Nonce is not saved!" + jwt <- Jwt.Jwt <$> getIdToken + sessionStoreDelete store + idToken <- liftIO $ validateIdToken oidc jwt + when (fromMaybe True $ (/=) <$> savedNonce <*> nonce idToken) + $ liftIO + $ throwIO + $ ValidationException "Nonce does not match request." + pure idToken + else liftIO $ throwIO $ ValidationException $ "Incosistent state: " <> decodeUtf8 stateFromIdP + +-- | Make URL for Authorization Request. +{-# 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 -- ^ used to specify what are privileges requested for tokens. (use `ScopeValue`) + -> Maybe State -- ^ used for CSRF mitigation. (recommended parameter) + -> Parameters -- ^ Optional parameters + -> m URI +getAuthenticationRequestUrl oidc scope state params = do + req <- liftIO $ parseUrl endpoint `catch` I.rethrow + return $ getUri $ setQueryString query req + where + endpoint = oidcAuthorizationServerUrl oidc + query = requireds ++ state' ++ params + requireds = + [ ("response_type", Just "id_token") + , ("response_mode", Just "form_post") + , ("client_id", Just $ oidcClientId oidc) + , ("redirect_uri", Just $ oidcRedirectUri oidc) + , ("scope", Just . B.pack . unwords . nub . map unpack $ openId:scope) + ] + state' = + case state of + Just _ -> [("state", state)] + Nothing -> [] diff --git a/src/Web/OIDC/Client/Tokens.hs b/src/Web/OIDC/Client/Tokens.hs --- a/src/Web/OIDC/Client/Tokens.hs +++ b/src/Web/OIDC/Client/Tokens.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-| Module: Web.OIDC.Client.Tokens @@ -7,20 +8,31 @@ Stability: experimental -} module Web.OIDC.Client.Tokens - ( - Tokens(..) + ( Tokens(..) , IdTokenClaims(..) - ) where + , validateIdToken + ) +where -import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON (parseJSON), Value (Object), - withObject, (.:), (.:?)) -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import GHC.Generics (Generic) -import Jose.Jwt (IntDate) -import Prelude hiding (exp) +import Control.Applicative ((<|>)) +import Control.Exception (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON (parseJSON), + FromJSON, Value (Object), + eitherDecode, withObject, + (.:), (.:?)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Either (partitionEithers) +import Data.Text (Text, pack) +import Data.Text.Encoding (encodeUtf8) +import GHC.Generics (Generic) +import Jose.Jwt (IntDate, Jwt, JwtContent (Jwe, Jws, Unsecured)) +import qualified Jose.Jwt as Jwt +import Prelude hiding (exp) +import qualified Web.OIDC.Client.Discovery.Provider as P +import Web.OIDC.Client.Settings (OIDC (..)) +import Web.OIDC.Client.Types (OpenIdException (..)) data Tokens a = Tokens { accessToken :: Text @@ -44,7 +56,6 @@ } deriving (Show, Eq, Generic) - instance FromJSON a => FromJSON (IdTokenClaims a) where parseJSON = withObject "IdTokenClaims" $ \o -> IdTokenClaims @@ -55,3 +66,34 @@ <*> o .: "iat" <*> (fmap encodeUtf8 <$> o .:? "nonce") <*> parseJSON (Object o) + +validateIdToken :: (MonadIO m, FromJSON a) => OIDC -> Jwt -> m (IdTokenClaims a) +validateIdToken oidc jwt' = do + let jwks = P.jwkSet . oidcProvider $ oidc + token = Jwt.unJwt jwt' + algs = P.idTokenSigningAlgValuesSupported + . P.configuration + $ oidcProvider oidc + decoded <- + selectDecodedResult + <$> traverse + (tryDecode jwks token) + algs + case decoded of + Right (Unsecured payload) -> liftIO . throwIO $ UnsecuredJwt payload + Right (Jws (_header, payload)) -> parsePayload payload + Right (Jwe (_header, payload)) -> parsePayload payload + Left err -> liftIO . throwIO $ JwtExceptoin err + where + tryDecode jwks token = \case + P.JwsAlgJson alg -> liftIO $ Jwt.decode jwks (Just $ Jwt.JwsEncoding alg) token + P.Unsupported alg -> return $ Left $ Jwt.BadAlgorithm ("Unsupported algorithm: " <> alg) + + selectDecodedResult xs = case partitionEithers xs of + (_, k : _) -> Right k + (e : _, _) -> Left e + ([], []) -> Left $ Jwt.KeyError "No Keys available for decoding" + + parsePayload payload = case eitherDecode $ BL.fromStrict payload of + Right x -> return x + Left err -> liftIO . throwIO . JsonException $ pack err