oidc-client 0.3.0.1 → 0.4.0.0
raw patch · 16 files changed
+542/−270 lines, 16 filesdep +cryptonitedep +mtldep +scientificdep ~aeson
Dependencies added: cryptonite, mtl, scientific
Dependency ranges changed: aeson
Files
- CHANGELOG.md +41/−0
- README.md +35/−0
- examples/scotty/Main.hs +145/−71
- oidc-client.cabal +10/−1
- src/Web/OIDC/Client.hs +6/−6
- src/Web/OIDC/Client/CodeFlow.hs +104/−48
- src/Web/OIDC/Client/Discovery.hs +13/−11
- src/Web/OIDC/Client/Discovery/Issuers.hs +1/−1
- src/Web/OIDC/Client/Discovery/Provider.hs +29/−7
- src/Web/OIDC/Client/Internal.hs +24/−31
- src/Web/OIDC/Client/Settings.hs +3/−3
- src/Web/OIDC/Client/Tokens.hs +39/−23
- src/Web/OIDC/Client/Types.hs +24/−7
- test/Spec.hs +2/−2
- test/Spec/Client.hs +50/−49
- test/Spec/Client/Internal.hs +16/−10
+ CHANGELOG.md view
@@ -0,0 +1,41 @@+# ChangeLog++## [Unreleased]++Nothing yet.++## [0.4.0.0]++### Added+- Added a validation of 'nonce' parameter. See [#24](https://github.com/krdlab/haskell-oidc-client/pull/24).+- Made optional claims available. See [#24](https://github.com/krdlab/haskell-oidc-client/pull/24).+- The lifecycles of 'nonce' and 'state' can also be managed by `SessionStore`. See [#24](https://github.com/krdlab/haskell-oidc-client/pull/24).++### Changed+- Made `TokenResponse` parsing strict. See [#23](https://github.com/krdlab/haskell-oidc-client/pull/23).+- A signing algorithm is now obtained from OpenID Provider Metadata. See [#24](https://github.com/krdlab/haskell-oidc-client/pull/24).+- 'profile' scope added to 'examples/scotty', and name / email / picture shown. See [#25](https://github.com/krdlab/haskell-oidc-client/pull/25).++## [0.3.0.1]+### Changed+- 'expires_in' can now parsed both String and Decimal number. See [#15](https://github.com/krdlab/haskell-oidc-client/pull/15).+### Fixed+- Improved error messages. See [#15](https://github.com/krdlab/haskell-oidc-client/pull/15).++## [0.3.0.0]+### Changed+- Changed `Configuration` fileds. See [#11](https://github.com/krdlab/haskell-oidc-client/pull/11).+### Fixed+- Fixed Hackage tarball. See [#13](https://github.com/krdlab/haskell-oidc-client/pull/13).++## [0.2.0.0]+### Changed+- Refactored modules, exports, types, and functions.++## [0.1.0.1]+### Changed+- Adjusted dependency version.++## [0.1.0.0]++First public release.
+ README.md view
@@ -0,0 +1,35 @@+# OpenID Connect 1.0 library for Relying Party++[](https://circleci.com/gh/krdlab/haskell-oidc-client)++This package supports implementing of an OpenID Connect 1.0 Relying Party. It's written in Haskell.++This package uses [jose-jwt](http://github.com/tekul/jose-jwt) package for decoding a received tokens.++## Usage++```sh+$ cabal update+$ cabal install oidc-client+```++The documentation is available in [Hackage](https://hackage.haskell.org/package/oidc-client).++## Run example++`examples/scotty` is a runnable code. If you try to run it, execute commands as follows:++```sh+$ stack build --flag oidc-client:build-examples+```++and then++```sh+$ export OPENID_CLIENT_BASE_URL="http://localhost:3000"+$ export OPENID_CLIENT_ID="Your client ID"+$ export OPENID_CLIENT_SECRET="Your client secret"+$ stack exec scotty-example+```++You can access to <http://localhost:3000/login>.
examples/scotty/Main.hs view
@@ -1,102 +1,176 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-} module Main where -import Control.Monad.IO.Class (liftIO)-import Crypto.Random.AESCtr (makeSystem)-import Crypto.Random.API (CPRG, cprgGenBytes)-import Data.ByteString (ByteString)-import Data.ByteString.Base64.URL (encode)-import qualified Data.ByteString.Char8 as B-import Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef)-import Data.Map (Map)-import qualified Data.Map as M-import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8)-import Data.Text.Lazy (pack)-import Data.Tuple (swap)-import Network.HTTP.Client (newManager, Manager)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import Network.HTTP.Types (badRequest400, unauthorized401)-import Network.Wai.Middleware.RequestLogger (logStdoutDev)-import System.Environment (getEnv)-import Text.Blaze.Html.Renderer.Text (renderHtml)-import Text.Blaze.Html5 ((!))-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A-import qualified Web.OIDC.Client as O-import Web.Scotty (scotty, middleware, get, param, post, redirect, html, status, text, rescue)-import Web.Scotty.Cookie (setSimpleCookie, getCookie)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ReaderT, ask, lift,+ runReaderT)+import Crypto.Random.AESCtr (AESRNG, makeSystem)+import Crypto.Random.API (cprgGenBytes)+import Data.Aeson (FromJSON)+import Data.ByteString (ByteString)+import Data.ByteString.Base64.URL (encode)+import qualified Data.ByteString.Char8 as B+import Data.IORef (IORef,+ atomicModifyIORef',+ newIORef, readIORef)+import Data.List as L+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (Maybe (..), fromMaybe)+import Data.Monoid ((<>))+import Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Data.Text.Lazy as TL+import Data.Tuple (swap)+import GHC.Generics (Generic)+import Network.HTTP.Client (Manager, newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (badRequest400,+ unauthorized401)+import Network.Wai.Middleware.RequestLogger (logStdoutDev)+import System.Environment (getEnv)+import Text.Blaze.Html (Html)+import Text.Blaze.Html.Renderer.Text (renderHtml)+import Text.Blaze.Html5 ((!))+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import qualified Web.OIDC.Client as O+import Web.Scotty.Cookie (getCookie,+ setSimpleCookie)+import Web.Scotty.Trans (ScottyT, get, html,+ middleware, param, post,+ redirect, rescue,+ scottyT, status, text) -type SessionStateMap = Map Text O.State+type SessionStateMap = Map T.Text (O.State, O.Nonce) -redirectUri :: ByteString-redirectUri = "http://localhost:3000/callback"+data AuthServerEnv = AuthServerEnv+ { oidc :: O.OIDC+ , cprg :: IORef AESRNG+ , ssm :: IORef SessionStateMap+ , mgr :: Manager+ } +type AuthServer a = ScottyT TL.Text (ReaderT AuthServerEnv IO) a++data ProfileClaims = ProfileClaims+ { name :: T.Text+ , email :: T.Text+ , picture :: T.Text+ } deriving (Show, Generic)++instance FromJSON ProfileClaims+ main :: IO () main = do+ baseUrl <- B.pack <$> getEnv "OPENID_CLIENT_BASE_URL" clientId <- B.pack <$> getEnv "OPENID_CLIENT_ID" clientSecret <- B.pack <$> getEnv "OPENID_CLIENT_SECRET" + let port = getPort baseUrl+ redirectUri = baseUrl <> "/login/cb"+ cprg <- makeSystem >>= newIORef ssm <- newIORef M.empty mgr <- newManager tlsManagerSettings- prov <- O.discover O.google mgr+ prov <- O.discover "https://accounts.google.com" mgr let oidc = O.setCredentials clientId clientSecret redirectUri $ O.newOIDC prov - run oidc cprg ssm mgr+ run port oidc cprg ssm mgr -run :: CPRG g => O.OIDC -> IORef g -> IORef SessionStateMap -> Manager -> IO ()-run oidc cprg ssm mgr = scotty 3000 $ do+getPort :: ByteString -> Int+getPort bs = fromMaybe 3000 port+ where+ port = case B.split ':' bs of+ [] -> Nothing+ [_] -> Nothing+ xs -> let p = (!! 0) . L.reverse $ xs+ in fst <$> B.readInt p++run :: Int -> O.OIDC -> IORef AESRNG -> IORef SessionStateMap -> Manager -> IO ()+run port oidc cprg ssm mgr = scottyT port runReader run'+ where+ runReader a = runReaderT a (AuthServerEnv oidc cprg ssm mgr)++run' :: AuthServer ()+run' = do middleware logStdoutDev get "/login" $- blaze $ do- H.h1 "Login"- H.form ! A.method "post" ! A.action "/login" $- H.button ! A.type_ "submit" $ "login"+ blaze htmlLogin post "/login" $ do- state <- genState- loc <- liftIO $ O.getAuthenticationRequestUrl oidc [O.email] (Just state) []- sid <- genSessionId- saveState sid state- setSimpleCookie "test-session" sid- redirect $ pack . show $ loc+ AuthServerEnv{..} <- lift ask - get "/callback" $ do+ sid <- genSessionId cprg+ let store = sessionStoreFromSession cprg ssm sid+ loc <- liftIO $ O.prepareAuthenticationRequestUrl store oidc [O.email, O.profile] []+ setSimpleCookie cookieName sid+ redirect . TL.pack . show $ loc++ get "/login/cb" $ do err <- param' "error" case err of- Just err' -> status401 err'- Nothing -> do- code :: O.Code <- param "code"- state :: O.State <- param "state"- cookie <- getCookie "test-session"- case cookie of- Just sid -> do- sst <- getStateBy sid- if state == sst- then do- tokens <- liftIO $ O.requestTokens oidc code mgr- blaze $ do- H.h1 "Result"- H.pre . H.toHtml . show . O.claims . O.idToken $ tokens- else status400 "state not match"- Nothing -> status400 "cookie not found"+ Just e -> status401 e+ Nothing -> getCookie cookieName >>= doCallback where+ cookieName = "test-session"++ htmlLogin = do+ H.h1 "Login"+ H.form ! A.method "post" ! A.action "/login" $+ H.button ! A.type_ "submit" $ "login"++ doCallback cookie =+ case cookie of+ Just sid -> do+ AuthServerEnv{..} <- lift ask+ let store = sessionStoreFromSession cprg ssm sid+ state <- param "state"+ code <- param "code"+ tokens <- liftIO $ O.getValidTokens store oidc mgr state code+ blaze $ htmlResult tokens+ Nothing -> status400 "cookie not found"++ htmlResult :: O.Tokens ProfileClaims -> Html+ htmlResult tokens = do+ H.h1 "Result"+ H.pre . H.toHtml . show $ tokens+ let profile = O.otherClaims $ O.idToken tokens+ H.div $ do+ H.p $ do+ H.toHtml ("Name: " :: T.Text)+ H.toHtml (name profile)+ H.p $ do+ H.toHtml ("Email: " :: T.Text)+ H.toHtml (email profile)+ H.p $ H.img ! (A.src $ H.textValue $ picture profile)++ gen cprg = encode <$> atomicModifyIORef' cprg (swap . cprgGenBytes 64)+ genSessionId cprg = liftIO $ decodeUtf8 <$> gen cprg+ genBytes cprg = liftIO $ gen cprg+ saveState ssm sid st nonce = liftIO $ atomicModifyIORef' ssm $ \m -> (M.insert sid (st, nonce) m, ())+ getStateBy ssm sid = liftIO $ do+ m <- M.lookup sid <$> readIORef ssm+ return $ case m of+ Just (st, nonce) -> (Just st, Just nonce)+ _ -> (Nothing, Nothing)+ deleteState ssm sid = liftIO $ atomicModifyIORef' ssm $ \m -> (M.delete sid m, ())++ sessionStoreFromSession cprg ssm sid =+ O.SessionStore+ { sessionStoreGenerate = genBytes cprg+ , sessionStoreSave = saveState ssm sid+ , sessionStoreGet = getStateBy ssm sid+ , sessionStoreDelete = deleteState ssm sid+ }+ blaze = html . renderHtml param' n = (Just <$> param n) `rescue` (\_ -> return Nothing)- status400 m = status badRequest400 >> text m+ status400 m = status badRequest400 >> text m status401 m = status unauthorized401 >> text m-- gen = encode <$> atomicModifyIORef' cprg (swap . cprgGenBytes 64)- genSessionId = liftIO $ decodeUtf8 <$> gen- genState = liftIO gen- saveState sid st = liftIO $ atomicModifyIORef' ssm $ \m -> (M.insert sid st m, ())- getStateBy sid = liftIO $ do- m <- readIORef ssm- case M.lookup sid m of- Just st -> return st- Nothing -> return ""
oidc-client.cabal view
@@ -1,5 +1,5 @@ name: oidc-client-version: 0.3.0.1+version: 0.4.0.0 synopsis: OpenID Connect 1.0 library for RP homepage: https://github.com/krdlab/haskell-oidc-client stability: experimental@@ -15,6 +15,8 @@ This package supports implementing of an OpenID Connect 1.0 Relying Party. . Examples: <https://github.com/krdlab/haskell-oidc-client/tree/master/examples>+extra-source-files: CHANGELOG.md+ , README.md source-repository head type: git@@ -46,12 +48,14 @@ , bytestring >=0.10 && <0.11 , text >=1.2 && <1.3 , aeson >=0.10+ , scientific , attoparsec >=0.12 , exceptions , http-client , tls >=1.3.2 , http-client-tls , jose-jwt >=0.7+ , cryptonite , time if flag(network-uri) build-depends: network-uri >=2.6, network >=2.6@@ -80,6 +84,7 @@ , Web.OIDC.Client.Types build-depends: base+ , aeson , hspec , oidc-client , bytestring@@ -88,7 +93,9 @@ , http-client , http-client-tls , aeson+ , scientific , jose-jwt+ , cryptonite , exceptions , time , network-uri@@ -102,10 +109,12 @@ build-depends: base >=4.7 && <5 , oidc-client+ , aeson , bytestring , text , containers , transformers+ , mtl , wai-extra , scotty , scotty-cookie
src/Web/OIDC/Client.hs view
@@ -22,12 +22,12 @@ , module Jose.Jwt ) where -import Web.OIDC.Client.CodeFlow-import Web.OIDC.Client.Settings (OIDC, newOIDC, setCredentials)-import Web.OIDC.Client.Discovery-import Web.OIDC.Client.Tokens-import Web.OIDC.Client.Types+import Web.OIDC.Client.CodeFlow+import Web.OIDC.Client.Discovery+import Web.OIDC.Client.Settings (OIDC, newOIDC, setCredentials)+import Web.OIDC.Client.Tokens+import Web.OIDC.Client.Types -import Jose.Jwt+import Jose.Jwt {-# ANN module "HLint: ignore Use import/export shortcut" #-}
src/Web/OIDC/Client/CodeFlow.hs view
@@ -7,6 +7,8 @@ module Web.OIDC.Client.CodeFlow ( getAuthenticationRequestUrl+ , getValidTokens+ , prepareAuthenticationRequestUrl , requestTokens -- * For testing@@ -14,28 +16,78 @@ , getCurrentIntDate ) where -import Control.Monad (unless)-import Control.Monad.Catch (MonadThrow, throwM, MonadCatch, catch)-import Data.Aeson (eitherDecode)-import qualified Data.ByteString.Char8 as B-import Data.List (nub)-import Data.Monoid ((<>))-import Data.Text (Text, pack, unpack)-import Data.Text.Encoding (decodeUtf8)-import Data.Time.Clock.POSIX (getPOSIXTime)-import Jose.Jwt (Jwt)-import qualified Jose.Jwt as Jwt-import Network.HTTP.Client (getUri, setQueryString, urlEncodedBody, Request(..), Manager, httpLbs, responseBody)-import Network.URI (URI)+import Control.Monad (unless, when)+import Control.Monad.Catch (MonadCatch, MonadThrow,+ catch, throwM)+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.List (nub)+import Data.Maybe (isNothing, listToMaybe)+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,+ responseBody,+ setQueryString,+ urlEncodedBody)+import Network.URI (URI) -import Web.OIDC.Client.Settings (OIDC(..))+import Prelude hiding (exp)+ import qualified Web.OIDC.Client.Discovery.Provider as P-import qualified Web.OIDC.Client.Internal as I-import Web.OIDC.Client.Internal (parseUrl)-import Web.OIDC.Client.Tokens (Tokens(..), IdToken(..))-import Web.OIDC.Client.Types (Scope, openId, Code, State, Parameters, OpenIdException(..))+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 (..),+ Tokens (..))+import Web.OIDC.Client.Types (Code, Nonce,+ OpenIdException (..),+ Parameters, Scope,+ SessionStore (..), State,+ openId) +-- | Make URL for Authorization Request after generating state and nonce from 'SessionStore'.+prepareAuthenticationRequestUrl+ :: (MonadThrow m, MonadCatch 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'.+getValidTokens+ :: (MonadThrow m, MonadCatch m, MonadIO m, FromJSON a)+ => SessionStore m+ -> OIDC+ -> Manager+ -> State+ -> Code+ -> m (Tokens a)+getValidTokens store oidc mgr stateFromIdP code = do+ (state, savedNonce) <- sessionStoreGet store+ if state == Just stateFromIdP+ then do+ when (isNothing savedNonce) $ throwM $ ValidationException "Nonce is not saved!"+ result <- liftIO $ requestTokens oidc savedNonce code mgr+ sessionStoreDelete store+ return result+ else throwM $ 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 :: (MonadThrow m, MonadCatch m) => OIDC@@ -68,12 +120,13 @@ -- Returned `Tokens` value is a valid. -- -- If a HTTP error has occurred or a tokens validation has failed, this function throws `OpenIdException`.-requestTokens :: OIDC -> Code -> Manager -> IO Tokens-requestTokens oidc code manager = do+{-# WARNING requestTokens "This function doesn't manage state and nonce. Use getValidTokens only unless your IdP doesn't support state and/or nonce." #-}+requestTokens :: FromJSON a => OIDC -> Maybe Nonce -> Code -> Manager -> IO (Tokens a)+requestTokens oidc savedNonce code manager = do json <- getTokensJson `catch` I.rethrow case eitherDecode json of- Right ts -> validate oidc ts- Left err -> error $ "failed to decode tokens json: " ++ err -- TODO: Exception+ Right ts -> validate oidc savedNonce ts+ Left err -> throwM . JsonException $ pack err where getTokensJson = do req <- parseUrl endpoint@@ -92,59 +145,62 @@ , ("redirect_uri", redirect) ] -validate :: OIDC -> I.TokensResponse -> IO Tokens-validate oidc tres = do+validate :: FromJSON a => OIDC -> Maybe Nonce -> I.TokensResponse -> IO (Tokens a)+validate oidc savedNonce tres = do let jwt' = I.idToken tres- validateIdToken oidc jwt'- claims' <- getClaims jwt'+ claims' <- validateIdToken oidc jwt' now <- getCurrentIntDate validateClaims (P.issuer . P.configuration . oidcProvider $ oidc) (decodeUtf8 . oidcClientId $ oidc) now+ savedNonce claims' return Tokens { accessToken = I.accessToken tres , tokenType = I.tokenType tres- , idToken = IdToken { claims = I.toIdTokenClaims claims', jwt = jwt' }+ , idToken = claims' , expiresIn = I.expiresIn tres , refreshToken = I.refreshToken tres } -validateIdToken :: OIDC -> Jwt -> IO ()+validateIdToken :: FromJSON a => OIDC -> Jwt -> IO (IdTokenClaims a) validateIdToken oidc jwt' = do let jwks = P.jwkSet . oidcProvider $ oidc token = Jwt.unJwt jwt'- decoded <- Jwt.decode jwks Nothing token+ alg = fmap (Jwt.JwsEncoding . P.getJwsAlg)+ . listToMaybe+ . P.idTokenSigningAlgValuesSupported+ . P.configuration+ $ oidcProvider oidc+ decoded <- Jwt.decode jwks alg token case decoded of- Right _ -> return ()- Left err -> throwM $ JwtExceptoin err+ Right (Unsecured payload) -> throwM $ UnsecuredJwt payload+ Right (Jws (_header, payload)) -> parsePayload payload+ Right (Jwe (_header, payload)) -> parsePayload payload+ Left err -> throwM $ JwtExceptoin err -getClaims :: MonadThrow m => Jwt -> m Jwt.JwtClaims-getClaims jwt' = case Jwt.decodeClaims (Jwt.unJwt jwt') of- Right (_, c) -> return c- Left cause -> throwM $ JwtExceptoin cause+ where+ parsePayload payload =+ case eitherDecode $ BL.fromStrict payload of+ Right x -> return x+ Left err -> throwM . JsonException $ pack err -validateClaims :: Text -> Text -> Jwt.IntDate -> Jwt.JwtClaims -> IO ()-validateClaims issuer' clientId' now claims' = do- iss' <- getIss claims'+validateClaims :: Text -> Text -> Jwt.IntDate -> Maybe Nonce -> IdTokenClaims a -> IO ()+validateClaims issuer' clientId' now savedNonce claims' = do+ let iss' = iss claims' unless (iss' == issuer') $ throwM $ ValidationException $ "issuer from token \"" <> iss' <> "\" is different than expected issuer \"" <> issuer' <> "\"" - aud' <- getAud claims'+ let aud' = aud claims' unless (clientId' `elem` aud') $ throwM $ ValidationException $ "our client \"" <> clientId' <> "\" isn't contained in the token's audience " <> (pack . show) aud' - exp' <- getExp claims'- unless (now < exp')+ unless (now < exp claims') $ throwM $ ValidationException "received token has expired"- where- getIss c = get Jwt.jwtIss c "'iss' claim was not found"- getAud c = get Jwt.jwtAud c "'aud' claim was not found"- getExp c = get Jwt.jwtExp c "'exp' claim was not found"- get f v msg = case f v of- Just v' -> return v'- Nothing -> throwM $ ValidationException msg++ unless (nonce claims' == savedNonce)+ $ throwM $ ValidationException "Inconsistent nonce" getCurrentIntDate :: IO Jwt.IntDate getCurrentIntDate = Jwt.IntDate <$> getPOSIXTime
src/Web/OIDC/Client/Discovery.hs view
@@ -16,17 +16,19 @@ , Configuration(..) ) where -import Control.Monad.Catch (throwM, catch)-import Data.Aeson (decode)-import Data.Text (append)-import Data.Maybe (fromMaybe)-import qualified Jose.Jwk as Jwk-import Network.HTTP.Client (Manager, httpLbs, responseBody)+import Control.Monad.Catch (catch, throwM)+import Data.Aeson (decode)+import Data.Text (append)+import qualified Jose.Jwk as Jwk+import Network.HTTP.Client (Manager, httpLbs,+ responseBody) -import Web.OIDC.Client.Discovery.Issuers (google)-import Web.OIDC.Client.Discovery.Provider (Provider(..), Configuration(..))-import Web.OIDC.Client.Internal (rethrow, parseUrl)-import Web.OIDC.Client.Types (IssuerLocation, OpenIdException(..))+import Web.OIDC.Client.Discovery.Issuers (google)+import Web.OIDC.Client.Discovery.Provider (Configuration (..),+ Provider (..))+import Web.OIDC.Client.Internal (parseUrl, rethrow)+import Web.OIDC.Client.Types (IssuerLocation,+ OpenIdException (..)) -- | This function obtains OpenID Provider configuration and JWK set. discover@@ -47,7 +49,7 @@ req <- parseUrl url res <- httpLbs req manager return $ responseBody res- jwks j = fromMaybe single (Jwk.keys <$> decode j)+ jwks j = maybe single Jwk.keys (decode j) where single = case decode j of Just k -> return k
src/Web/OIDC/Client/Discovery/Issuers.hs view
@@ -10,7 +10,7 @@ -- TODO: other services ) where -import Web.OIDC.Client.Types (IssuerLocation)+import Web.OIDC.Client.Types (IssuerLocation) google :: IssuerLocation google = "https://accounts.google.com"
src/Web/OIDC/Client/Discovery/Provider.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} {-| Module: Web.OIDC.Client.Discovery.Provider Maintainer: krdlab@gmail.com@@ -9,18 +10,39 @@ ( Provider(..) , Configuration(..)+ , JwsAlgJson(..) ) where -import Data.Aeson.TH (deriveFromJSON, Options(..), defaultOptions)-import Data.Aeson.Types (camelTo2)-import Data.Text (Text)-import Jose.Jwk (Jwk)+import Data.Aeson (FromJSON, parseJSON, withText)+import Data.Aeson.TH (Options (..), defaultOptions,+ deriveFromJSON)+import Data.Aeson.Types (camelTo2)+import Data.Text (Text, unpack)+import Jose.Jwa (JwsAlg (..))+import Jose.Jwk (Jwk) -import Web.OIDC.Client.Types (ScopeValue, IssuerLocation)+import Web.OIDC.Client.Types (IssuerLocation, ScopeValue) -- | An OpenID Provider information data Provider = Provider { configuration :: Configuration, jwkSet :: [Jwk] } +newtype JwsAlgJson = JwsAlgJson { getJwsAlg :: JwsAlg } deriving (Show, Eq)++instance FromJSON JwsAlgJson where+ parseJSON = withText "JwsAlgJson" $ \case+ "HS256" -> pure $ JwsAlgJson HS256+ "HS384" -> pure $ JwsAlgJson HS384+ "HS512" -> pure $ JwsAlgJson HS512+ "RS256" -> pure $ JwsAlgJson RS256+ "RS384" -> pure $ JwsAlgJson RS384+ "RS512" -> pure $ JwsAlgJson RS512+ "ES256" -> pure $ JwsAlgJson ES256+ "ES384" -> pure $ JwsAlgJson ES384+ "ES512" -> pure $ JwsAlgJson ES512+ "none" -> pure $ JwsAlgJson None+ other -> fail $ "Non-supported alg: " <> show (unpack other)++ -- | An OpenID Provider Configuration data Configuration = Configuration { issuer :: IssuerLocation@@ -31,7 +53,7 @@ , jwksUri :: Text , responseTypesSupported :: [Text] , subjectTypesSupported :: [Text]- , idTokenSigningAlgValuesSupported :: [Text]+ , idTokenSigningAlgValuesSupported :: [JwsAlgJson] , scopesSupported :: Maybe [ScopeValue] , tokenEndpointAuthMethodsSupported :: Maybe [Text] , claimsSupported :: Maybe [Text]
src/Web/OIDC/Client/Internal.hs view
@@ -6,25 +6,25 @@ -} module Web.OIDC.Client.Internal where -import Control.Applicative ((<|>))-import Control.Monad (mzero)-import Control.Monad.Catch (MonadThrow, throwM, MonadCatch)-import Data.Aeson (FromJSON, parseJSON, Value(..), (.:), (.:?))-import Data.Maybe (fromJust)-import Data.Text (Text, unpack)-import Data.Text.Read (decimal)-import Jose.Jwt (Jwt, JwtClaims(..))-import Network.HTTP.Client (HttpException, parseRequest, Request)-import Prelude hiding (exp)-import Web.OIDC.Client.Tokens (IdTokenClaims(..))-import Web.OIDC.Client.Types (OpenIdException(InternalHttpException))+import Control.Applicative ((<|>))+import Control.Monad (mzero)+import Control.Monad.Catch (MonadCatch, MonadThrow, throwM)+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:),+ (.:?))+import Data.Aeson.Types (Parser)+import Data.Text (Text, unpack)+import Data.Text.Read (decimal)+import Jose.Jwt (Jwt)+import Network.HTTP.Client (HttpException, Request, parseRequest)+import Prelude hiding (exp)+import Web.OIDC.Client.Types (OpenIdException (InternalHttpException)) data TokensResponse = TokensResponse- { accessToken :: !Text- , tokenType :: !Text- , idToken :: !Jwt- , expiresIn :: !(Maybe Integer)- , refreshToken :: !(Maybe Text)+ { accessToken :: !Text+ , tokenType :: !Text+ , idToken :: !Jwt+ , expiresIn :: !(Maybe Integer)+ , refreshToken :: !(Maybe Text) } deriving (Show, Eq) @@ -33,26 +33,19 @@ <$> o .: "access_token" <*> o .: "token_type" <*> o .: "id_token"- <*> (o .:? "expires_in" <|> (>>= textToInt) <$> (o .:? "expires_in"))+ <*> ((o .:? "expires_in") <|> (textToInt =<< (o .:? "expires_in"))) <*> o .:? "refresh_token" parseJSON _ = mzero -textToInt :: Text -> Maybe Integer-textToInt t = case decimal t of- Right (i, _) -> Just i- Left _ -> Nothing+textToInt :: Maybe Text -> Parser (Maybe Integer)+textToInt (Just t) =+ case decimal t of+ Right (i, _) -> pure $ Just i+ Left _ -> fail "expires_in: expected a decimal text, encountered a non decimal text"+textToInt _ = pure Nothing rethrow :: (MonadCatch m) => HttpException -> m a rethrow = throwM . InternalHttpException--toIdTokenClaims :: JwtClaims -> IdTokenClaims-toIdTokenClaims c = IdTokenClaims -- FIXME: fromJust- { iss = fromJust (jwtIss c)- , sub = fromJust (jwtSub c)- , aud = fromJust (jwtAud c)- , exp = fromJust (jwtExp c)- , iat = fromJust (jwtIat c)- } parseUrl :: MonadThrow m => Text -> m Request parseUrl = Network.HTTP.Client.parseRequest . unpack
src/Web/OIDC/Client/Settings.hs view
@@ -12,10 +12,10 @@ , setCredentials ) where -import Data.ByteString (ByteString)-import Data.Text (Text)+import Data.ByteString (ByteString)+import Data.Text (Text) -import Web.OIDC.Client.Discovery.Provider (Provider)+import Web.OIDC.Client.Discovery.Provider (Provider) import qualified Web.OIDC.Client.Discovery.Provider as P -- | This data type represents information needed in the OpenID flow.
src/Web/OIDC/Client/Tokens.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+ {-| Module: Web.OIDC.Client.Tokens Maintainer: krdlab@gmail.com@@ -7,35 +9,49 @@ module Web.OIDC.Client.Tokens ( Tokens(..)- , IdToken(..) , IdTokenClaims(..) ) where -import Data.Text (Text)-import Jose.Jwt (Jwt, IntDate)-import Prelude hiding (exp)+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) -data Tokens = Tokens- { accessToken :: Text- , tokenType :: Text- , idToken :: IdToken- , expiresIn :: Maybe Integer- , refreshToken :: Maybe Text+data Tokens a = Tokens+ { accessToken :: Text+ , tokenType :: Text+ , idToken :: IdTokenClaims a+ , expiresIn :: Maybe Integer+ , refreshToken :: Maybe Text } deriving (Show, Eq) -data IdToken = IdToken- { claims :: IdTokenClaims- , jwt :: Jwt+-- | Claims required for an <https://openid.net/specs/openid-connect-core-1_0.html#IDToken ID Token>,+-- plus recommended claims (nonce) and other custom claims.+data IdTokenClaims a = IdTokenClaims+ { iss :: !Text+ , sub :: !Text+ , aud :: ![Text]+ , exp :: !IntDate+ , iat :: !IntDate+ , nonce :: !(Maybe ByteString)+ , otherClaims :: !a }- deriving (Show, Eq)+ deriving (Show, Eq, Generic) -data IdTokenClaims = IdTokenClaims- { iss :: Text- , sub :: Text- , aud :: [Text]- , exp :: IntDate- , iat :: IntDate- -- TODO: optional- }- deriving (Show, Eq)++instance FromJSON a => FromJSON (IdTokenClaims a) where+ parseJSON = withObject "IdTokenClaims" $ \o ->+ IdTokenClaims+ <$> o .: "iss"+ <*> o .: "sub"+ <*> (o .: "aud" <|> ((:[]) <$> (o .: "aud")))+ <*> o .: "exp"+ <*> o .: "iat"+ <*> (fmap encodeUtf8 <$> o .:? "nonce")+ <*> parseJSON (Object o)
src/Web/OIDC/Client/Types.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} {-| Module: Web.OIDC.Client.Types Maintainer: krdlab@gmail.com@@ -11,18 +11,20 @@ , openId, profile, email, address, phone, offlineAccess , Scope , State+ , Nonce , Parameters , Code , IssuerLocation , OpenIdException(..)+ , SessionStore (..) ) where -import Control.Exception (Exception)-import Data.ByteString (ByteString)-import Data.Text (Text)-import Data.Typeable (Typeable)-import Jose.Jwt (JwtError)-import Network.HTTP.Client (HttpException)+import Control.Exception (Exception)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Typeable (Typeable)+import Jose.Jwt (JwtError)+import Network.HTTP.Client (HttpException) type IssuerLocation = Text @@ -40,6 +42,8 @@ type State = ByteString +type Nonce = ByteString+ type Parameters = [(ByteString, Maybe ByteString)] type Code = ByteString@@ -47,8 +51,21 @@ data OpenIdException = DiscoveryException Text | InternalHttpException HttpException+ | JsonException Text+ | UnsecuredJwt ByteString | JwtExceptoin JwtError | ValidationException Text deriving (Show, Typeable) instance Exception OpenIdException++-- | Manages state and nonce.+-- (Maybe 'OIDC' should have them)+data SessionStore m = SessionStore+ { sessionStoreGenerate :: m ByteString+ -- ^ Generate state and nonce at random+ , sessionStoreSave :: State -> Nonce -> m ()+ , sessionStoreGet :: m (Maybe State, Maybe Nonce)+ , sessionStoreDelete :: m ()+ -- ^ Should delete at least nonce+ }
test/Spec.hs view
@@ -1,6 +1,6 @@-import Test.Hspec (hspec)-import qualified Spec.Client as Client+import qualified Spec.Client as Client import qualified Spec.Client.Internal as Internal+import Test.Hspec (hspec) main :: IO () main = hspec $ do
test/Spec/Client.hs view
@@ -1,20 +1,25 @@+{-# OPTIONS_GHC -Wno-warnings-deprecations #-} {-# LANGUAGE OverloadedStrings #-} module Spec.Client where -import Data.ByteString (ByteString)-import Data.Text (unpack)-import Data.Text.Encoding (decodeUtf8)-import Network.HTTP.Client (newManager)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import Network.HTTP.Types (urlEncode)-import Test.Hspec (Spec, describe, it, shouldContain, shouldNotContain, shouldThrow)-import Web.OIDC.Client+import Data.Aeson (Value (Null))+import Data.ByteString (ByteString)+import Data.Text (unpack)+import Data.Text.Encoding (decodeUtf8)+import Network.HTTP.Client (newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (urlEncode)+import Test.Hspec (Spec, describe, it, shouldContain,+ shouldNotContain, shouldThrow)+import Web.OIDC.Client -clientId, clientSecret, redirectUri, nonce :: ByteString+import Prelude hiding (exp)++clientId, clientSecret, redirectUri, nonce' :: ByteString clientId = "dummy client id" clientSecret = "dummy client secret" redirectUri = "http://localhost"-nonce = "dummy nonce"+nonce' = "dummy nonce" tests :: Spec tests = do@@ -36,66 +41,62 @@ provider <- discover google manager let oidc = setCredentials clientId clientSecret redirectUri $ newOIDC provider state = "dummy state"- url <- getAuthenticationRequestUrl oidc [email] (Just state) [("nonce", Just nonce)]+ url <- getAuthenticationRequestUrl oidc [email] (Just state) [("nonce", Just nonce')] show url `shouldContain` (toES "scope" ++ "=" ++ toES "openid email") show url `shouldContain` (toES "state" ++ "=" ++ toES state)- show url `shouldContain` (toES "nonce" ++ "=" ++ toES nonce)+ show url `shouldContain` (toES "nonce" ++ "=" ++ toES nonce') describe "CodeFlow.validateClaims" $ do+ let issuer' = "http://localhost"+ clientId' = decodeUtf8 clientId+ createValidClaims now =+ IdTokenClaims+ { iss = issuer'+ , sub = "sub"+ , aud = [clientId']+ , exp = add 10 now+ , iat = now+ , nonce = Just nonce'+ , otherClaims = Null+ } it "should succeed at a validation of correct claims" $ do- let issuer' = "http://localhost"- clientId' = decodeUtf8 clientId now <- getCurrentIntDate- let claims' = defClaims { jwtIss = Just issuer'- , jwtAud = Just [clientId']- , jwtExp = Just (add 10 now)- }- validateClaims issuer' clientId' now claims'- validateClaims issuer' clientId' now (claims' { jwtAud = Just ["other id", clientId'] })+ let claims' = createValidClaims now+ validateClaims issuer' clientId' now (Just nonce') claims'+ validateClaims issuer' clientId' now (Just nonce') claims' { aud = ["other id", clientId'] } it "should throw ValidationException if 'iss' field is invalid" $ do- let issuer' = "http://localhost"- clientId' = decodeUtf8 clientId now <- getCurrentIntDate- let claims' = defClaims { jwtIss = Just "http://localhost/hoge"- , jwtAud = Just [clientId']- , jwtExp = Just (add 10 now)- }- validateClaims issuer' clientId' now claims'+ let claims' = createValidClaims now+ validateClaims issuer' clientId' now (Just nonce') claims' { iss = "http://localhost/hoge" } `shouldThrow` isValidationException it "should throw ValidationException if 'aud' field does not contain Client ID" $ do- let issuer' = "http://localhost"- clientId' = decodeUtf8 clientId now <- getCurrentIntDate- let claims' = defClaims { jwtIss = Just issuer'- , jwtAud = Just ["other id"]- , jwtExp = Just (add 10 now)- }- validateClaims issuer' clientId' now claims'+ let claims' = createValidClaims now+ validateClaims issuer' clientId' now (Just nonce') claims' { aud = ["other id"] } `shouldThrow` isValidationException it "should throw ValidationException if 'exp' field expired" $ do- let issuer' = "http://localhost"- clientId' = decodeUtf8 clientId now <- getCurrentIntDate- let claims' = defClaims { jwtIss = Just issuer'- , jwtAud = Just [clientId']- , jwtExp = Just (add (-1) now)- }- validateClaims issuer' clientId' now claims'+ let claims' = createValidClaims now+ validateClaims issuer' clientId' now (Just nonce') claims' { exp = add (-1) now } `shouldThrow` isValidationException + it "should throw ValidationException if 'nonce' is not given" $ do+ now <- getCurrentIntDate+ let claims' = createValidClaims now+ validateClaims issuer' clientId' now (Just nonce') claims' { nonce = Nothing }+ `shouldThrow` isValidationException++ it "should throw ValidationException if 'nonce' is invalid" $ do+ now <- getCurrentIntDate+ let claims' = createValidClaims now+ validateClaims issuer' clientId' now (Just nonce') claims' { nonce = Just "other nonce" }+ `shouldThrow` isValidationException+ where toES = unpack . decodeUtf8 . urlEncode True- defClaims = JwtClaims { jwtIss = Nothing- , jwtSub = Nothing- , jwtAud = Nothing- , jwtExp = Nothing- , jwtNbf = Nothing- , jwtIat = Nothing- , jwtJti = Nothing- } add sec (IntDate t) = IntDate $ t + sec isValidationException e = case e of (ValidationException _) -> True
test/Spec/Client/Internal.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Spec.Client.Internal where -import Data.Aeson (decode)-import Jose.Jwt (Jwt(..))-import Test.Hspec (Spec, describe, it, shouldBe)+import Data.Aeson (eitherDecode)+import Data.Either (isLeft)+import Jose.Jwt (Jwt (..))+import Test.Hspec (Spec, describe, it, shouldBe,+ shouldSatisfy) import qualified Web.OIDC.Client.Internal as I tests :: Spec@@ -11,22 +13,26 @@ describe "Internal: Decode TokensResponse JSON data" $ do it "should be successful decoding a JSON data which has full fields" $ do let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\",\"expires_in\":123,\"refresh_token\":\"refresh token\"}"- decode json `shouldBe` Just (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") (Just 123) (Just "refresh token"))+ eitherDecode json `shouldBe` Right (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") (Just 123) (Just "refresh token")) it "should be successful decoding a JSON data without 'refresh_token' field" $ do let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\",\"expires_in\":123}"- decode json `shouldBe` Just (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") (Just 123) Nothing)+ eitherDecode json `shouldBe` Right (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") (Just 123) Nothing) it "should be successful decoding a JSON data without 'expires_in' and 'refresh_token' fields" $ do let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\"}"- decode json `shouldBe` Just (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") Nothing Nothing)+ eitherDecode json `shouldBe` Right (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") Nothing Nothing) it "should be failure decoding a JSON data from the lack of a required field" $ do let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\"}"- decode json `shouldBe` (Nothing :: Maybe I.TokensResponse)+ (eitherDecode json :: Either String I.TokensResponse) `shouldSatisfy` isLeft -- NOTE: The 'expires_in' field is an integer, is not included a fractional part. But, I received the report https://github.com/krdlab/haskell-oidc-client/pull/15. -- see also: https://tools.ietf.org/html/rfc6749#appendix-A.14- it "should be successful decoding a JSON data with 'expires_in' field which has a fractional part" $ do- let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\",\"expires_in\":123.45}"- decode json `shouldBe` Just (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") (Just 123) Nothing)+ it "should successfully decode a JSON data with 'expires_in' field whose value is a decimal text" $ do+ let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\",\"expires_in\":\"123.45\"}"+ eitherDecode json `shouldBe` Right (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") (Just 123) Nothing)++ it "should failed to decode a JSON data with 'expires_in' field value is a non-decimal text" $ do+ let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\",\"expires_in\":\"non-numeric\"}"+ (eitherDecode json :: Either String I.TokensResponse) `shouldSatisfy` isLeft