oidc-client 0.4.0.1 → 0.5.0.0

raw patch · 7 files changed

+190/−64 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−2
• oidc-client.cabal +2/−1
• src/Web/OIDC/Client/CodeFlow.hs +1/−31
• src/Web/OIDC/Client/Discovery.hs +19/−13
• src/Web/OIDC/Client/Discovery/Provider.hs +3/−4
• src/Web/OIDC/Client/IdTokenFlow.hs +102/−0
• src/Web/OIDC/Client/Tokens.hs +55/−13

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 -> []

@@ -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