openid-connect (empty) → 0.1.0.0
raw patch · 31 files changed
+3893/−0 lines, 31 filesdep +aesondep +basedep +blaze-htmlsetup-changed
Dependencies added: aeson, base, blaze-html, bytestring, case-insensitive, cookie, cryptonite, http-client, http-client-tls, http-types, jose, lens, memory, mtl, network-uri, openid-connect, optparse-applicative, servant, servant-blaze, servant-server, tasty, tasty-hunit, text, time, unordered-containers, warp, warp-tls
Files
- CHANGES.md +7/−0
- LICENSE +26/−0
- README.md +64/−0
- Setup.hs +2/−0
- example/Auth.hs +145/−0
- example/Discover.hs +127/−0
- example/Main.hs +44/−0
- example/Options.hs +203/−0
- example/Util.hs +59/−0
- example/certification.sh +224/−0
- example/make-tls-certs.sh +22/−0
- openid-connect.cabal +156/−0
- src/OpenID/Connect/Authentication.hs +185/−0
- src/OpenID/Connect/Client/Authentication.hs +131/−0
- src/OpenID/Connect/Client/DynamicRegistration.hs +77/−0
- src/OpenID/Connect/Client/Flow/AuthorizationCode.hs +439/−0
- src/OpenID/Connect/Client/HTTP.hs +158/−0
- src/OpenID/Connect/Client/Provider.hs +150/−0
- src/OpenID/Connect/Client/TokenResponse.hs +143/−0
- src/OpenID/Connect/Discovery.hs +214/−0
- src/OpenID/Connect/JSON.hs +169/−0
- src/OpenID/Connect/Provider/Key.hs +76/−0
- src/OpenID/Connect/Registration.hs +329/−0
- src/OpenID/Connect/Scope.hs +130/−0
- src/OpenID/Connect/TokenResponse.hs +75/−0
- test/Client.hs +32/−0
- test/Client/AuthorizationCodeTest.hs +255/−0
- test/Client/ProviderTest.hs +63/−0
- test/DiscoveryTest.hs +62/−0
- test/HttpHelper.hs +96/−0
- test/Main.hs +30/−0
+ CHANGES.md view
@@ -0,0 +1,7 @@+Revision History for `openid-connect`+=====================================++Version 0.1.0.0 (March 25, 2020)+--------------------------------++Initial release.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2020 Peter J. Jones <pjones@devalot.com>+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,64 @@+[](https://app.circleci.com/github/sthenauth/openid-connect/pipelines)++OpenID Connect 1.0 in Haskell+=============================++An OpenID Connect 1.0 compliant library written in Haskell.++The primary goals of this package are security and usability.++Client Features+---------------++This library mostly focuses on the client side of the OpenID Connect+protocol.++Supported flows:++ * [x] Authorization Code (see `OpenID.Connect.Client.Flow.AuthorizationCode`) (§3.1)+ * [ ] Implicit (partial implementation, patches welcome) (§3.2)+ * [ ] Hybrid (partial implementation, patches welcome) (§3.3)++Significant features:++ * ID Token validation via the [jose][] library (§2)+ * Additional OIDC claim validation (e.g., `nonce`, `azp`, etc.) (§2)+ * Full support for all defined forms of client authentication (§9)+ * Handles session cookie generation and validation (§3.1.2.1, §15.5.2)+ * Dynamic Client Registration 1.0.++Provider Features+-----------------++Some utility types and functions are available to assist in the+writing of an OIDC Provider:++ * Discovery document (OpenID Connect Discovery 1.0 §3)+ * Key generation (simple wrapper around [jose][])++[jose]: https://hackage.haskell.org/package/jose++Certification Status+--------------------++We plan on fully [certifying][cert] this implementation using the+following profiles:++ * [ ] Basic Relying Party+ * [ ] Implicit Relying Party+ * [ ] Hybrid Relying Party+ * [ ] Relying Party Using Configuration Information+ * [ ] Dynamic Relying Party+ * [ ] Form Post Relying Party++[cert]: https://openid.net/certification/instructions/++Specifications and RFCs+-----------------------++ * [OpenID Connect Core](http://openid.net/specs/openid-connect-core-1_0.html)+ * [OpenID Connect Discovery](http://openid.net/specs/openid-connect-discovery-1_0.html)+ * [The OAuth 2.0 Authorization Framework (RFC6749)](https://tools.ietf.org/html/rfc6749)+ * [JSON Web Token (RFC7519)](https://tools.ietf.org/html/rfc7519)+ * [JSON Web Signature (RFC7515)](https://tools.ietf.org/html/rfc7515)+ * [JSON Web Key (RFC7517)](https://www.rfc-editor.org/rfc/rfc7517.htmlhttps://www.rfc-editor.org/rfc/rfc7517.html)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Auth.hs view
@@ -0,0 +1,145 @@+{-|++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/sthenauth/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++-}+module Auth (app) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Monad.Except+import Data.ByteString (ByteString)+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.Proxy+import Data.Text (Text)+import Data.Text.Encoding as Text+import Data.Time.Clock (getCurrentTime)+import Network.HTTP.Client (Manager)+import Network.URI (uriToString)+import OpenID.Connect.Client.Flow.AuthorizationCode+import Servant.API+import Servant.HTML.Blaze+import Servant.Server+import Text.Blaze.Html+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import Util+import Web.Cookie++--------------------------------------------------------------------------------+type Index = "index"+ :> Get '[HTML] Html++--------------------------------------------------------------------------------+type Login = "login" :> Get '[HTML] Html++--------------------------------------------------------------------------------+type Success = "return"+ :> QueryParam "code" Text+ :> QueryParam "state" Text+ :> Header "cookie" SessionCookie+ :> Get '[HTML] Html++--------------------------------------------------------------------------------+type Failed = "return"+ :> QueryParam "error" Text+ :> QueryParam "state" Text+ :> Header "cookie" SessionCookie+ :> Get '[HTML] Html++--------------------------------------------------------------------------------+-- | Complete API.+type API = Index :<|> Login :<|> Success :<|> Failed++--------------------------------------------------------------------------------+-- | A type for getting the session cookie out of the request.+newtype SessionCookie = SessionCookie+ { getSessionCookie :: ByteString+ }++instance FromHttpApiData SessionCookie where+ parseUrlPiece = parseHeader . Text.encodeUtf8+ parseHeader bs =+ case lookup "session" (parseCookies bs) of+ Nothing -> Left "session cookie missing"+ Just val -> Right (SessionCookie val)++--------------------------------------------------------------------------------+api :: Proxy API+api = Proxy++--------------------------------------------------------------------------------+app :: Manager -> Provider -> Credentials -> Application+app mgr provider creds = serve api (handlers mgr provider creds)++--------------------------------------------------------------------------------+handlers :: Manager -> Provider -> Credentials -> Server API+handlers mgr provider creds =+ index :<|> login :<|> success :<|> failed+ where+ ----------------------------------------------------------------------------+ -- Return the login HTML.+ index :: Server Index+ index = pure . H.docTypeHtml $ do+ H.title "OpenID Connect Login"+ H.p (H.a H.! A.href "/login" $ "Login")++ ----------------------------------------------------------------------------+ -- Redirect the user to the provider.+ login :: Server Login+ login = do+ let req = defaultAuthenticationRequest openid creds+ r <- liftIO (authenticationRedirect (providerDiscovery provider) req)+ case r of+ Left e -> throwError (err403 { errBody = LChar8.pack (show e) })+ Right (RedirectTo uri cookie) ->+ throwError (err302+ { errHeaders =+ [ ("Location", Char8.pack (uriToString id uri []))+ , ("Set-Cookie", LChar8.toStrict+ (toLazyByteString (renderSetCookie (cookie "session"))))+ ]+ })++ ----------------------------------------------------------------------------+ -- User returned from provider with a successful authentication.+ success :: Server Success+ success (Just code) (Just state) (Just cookie) = do+ let browser = UserReturnFromRedirect+ { afterRedirectCodeParam = Text.encodeUtf8 code+ , afterRedirectStateParam = Text.encodeUtf8 state+ , afterRedirectSessionCookie = getSessionCookie cookie+ }++ now <- liftIO getCurrentTime+ r <- liftIO (authenticationSuccess (https mgr) now provider creds browser)+ case r of+ Left e -> throwError (err403 { errBody = LChar8.pack (show e) })+ Right _token -> pure . H.docTypeHtml $ do+ H.title "Success!"+ H.h1 "Successful Authentication"++ ----------------------------------------------------------------------------+ -- Should have been a success, but one or more params are missing.+ success _ _ _ = failed (Just "missing params") Nothing Nothing++ ----------------------------------------------------------------------------+ -- User returned from provider with an authentication failure.+ failed :: Server Failed+ failed err _ _ = throwError $+ err400 { errBody = maybe "WTF?" (LChar8.fromStrict . Text.encodeUtf8) err+ }
+ example/Discover.hs view
@@ -0,0 +1,127 @@+{-|++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/sthenauth/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++-}+module Discover+ ( getProvider+ , getCredentials+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Lens ((^.))+import Crypto.JOSE (JWK, JWKSet(..), asPublicKey)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy.Char8 as Char8+import Data.List.NonEmpty (NonEmpty(..))+import Data.Text (Text)+import Network.HTTP.Client (Manager)+import OpenID.Connect.Authentication+import OpenID.Connect.Client.DynamicRegistration as R+import OpenID.Connect.Client.Provider+import OpenID.Connect.Provider.Key+import Options+import Util++--------------------------------------------------------------------------------+-- | Fetch the provider's discovery document and signing keys.+getProvider :: Options -> Manager -> IO Provider+getProvider opts mgr =+ discoveryAndKeys (https mgr) (optionsProviderUri opts) >>= \case+ Left err -> fail (show err)+ Right (x, _) -> pure (x { providerDiscovery =+ updateDisco (providerDiscovery x) })++ where+ updateDisco :: Discovery -> Discovery+ updateDisco d =+ case optionsForceAuthMode opts of+ ForceSecretPost ->+ d {tokenEndpointAuthMethodsSupported =+ Just (ClientSecretPost :| [])}+ ForceSecretJWT ->+ d {tokenEndpointAuthMethodsSupported =+ Just (ClientSecretJwt :| [])}+ ForcePrivateJWT ->+ d {tokenEndpointAuthMethodsSupported =+ Just (PrivateKeyJwt :| [])}+ NoForcedAuth ->+ d++--------------------------------------------------------------------------------+-- | Construct client credentials.+getCredentials+ :: Options+ -> Manager+ -> Provider+ -> IO Credentials+getCredentials opts mgr provider =+ case optionsClientDetails opts of+ Direct cid csec -> pure (build csec cid)+ Register email -> register email++ where+ register :: Text -> IO Credentials+ register email = do+ key <- newSigningJWK+ let metadata = clientMetadata (regReq email key) BasicRegistration+ putStrLn "Performing dynamic client registration:"+ Char8.putStrLn (Aeson.encode metadata)++ registerClient (https mgr) (providerDiscovery provider) metadata >>= \case+ Left e -> fail (show e)+ Right x -> do+ let res = clientSecretsFromResponse x+ putStrLn "Registration successful:" >> print res+ pure (build (R.clientId res) (toClientSecret key (R.clientSecret res)))++ regReq :: Text -> JWK -> Registration+ regReq email key =+ let reg = defaultRegistration (optionsClientUri opts)+ in reg { R.contacts = Just (email :| [])+ , R.tokenEndpointAuthMethod = defaultAuthMethod+ , R.jwks = JWKSet . pure <$> (key ^. asPublicKey)+ }++ defaultAuthMethod :: ClientAuthentication+ defaultAuthMethod = case optionsForceAuthMode opts of+ ForceSecretPost -> ClientSecretPost+ ForceSecretJWT -> ClientSecretJwt+ ForcePrivateJWT -> PrivateKeyJwt+ NoForcedAuth -> ClientSecretBasic++ toClientSecret :: JWK -> Maybe Text -> ClientSecret+ toClientSecret key = \case+ Nothing ->+ case optionsForceAuthMode opts of+ ForceSecretPost -> AssignedSecretText "should fail"+ ForceSecretJWT -> AssignedAssertionText "should fail"+ ForcePrivateJWT -> AssertionPrivateKey key+ NoForcedAuth -> AssignedSecretText "should fail"+ Just sec ->+ case optionsForceAuthMode opts of+ ForceSecretPost -> AssignedSecretText sec+ ForceSecretJWT -> AssignedAssertionText sec+ ForcePrivateJWT -> AssertionPrivateKey key+ NoForcedAuth -> AssignedSecretText sec++ build :: Text -> ClientSecret -> Credentials+ build cid csec =+ Credentials+ { assignedClientId = cid+ , clientSecret = csec+ , clientRedirectUri = optionsClientUri opts+ }
+ example/Main.hs view
@@ -0,0 +1,44 @@+{-|++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/sthenauth/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++-}+module Main (main) where++--------------------------------------------------------------------------------+-- Imports:+import Auth+import Data.Function ((&))+import Discover+import Network.HTTP.Client.TLS (newTlsManager)+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WarpTLS as Warp+import Options++--------------------------------------------------------------------------------+-- | Start the web server.+main :: IO ()+main = do+ opts <- parseOptions++ let settings = Warp.defaultSettings & Warp.setPort (optionsPort opts)+ tls = Warp.tlsSettings (optionsCert opts) (optionsKey opts)++ mgr <- newTlsManager+ provider <- getProvider opts mgr+ creds <- getCredentials opts mgr provider++ putStrLn "Starting web server"+ Warp.runTLS tls settings (app mgr provider creds)
+ example/Options.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE QuasiQuotes #-}++{-|++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/sthenauth/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++-}+module Options+ ( Options(..)+ , ClientDetails(..)+ , ForceAuthMethod(..)+ , parseOptions+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Applicative+import Data.Text (Text)+import Network.URI (URI(..), URIAuth(..), parseURI)+import Network.URI.Static (uri)+import OpenID.Connect.Client.Flow.AuthorizationCode (ClientSecret(..))+import qualified Options.Applicative as O++--------------------------------------------------------------------------------+-- | How to get client info.+data ClientDetails+ = Direct+ { optionsClientSecret :: ClientSecret+ , optionsClientId :: Text+ }+ | Register+ { optionsClientContact :: Text+ }++--------------------------------------------------------------------------------+-- | Flags to force a certain client authentication method.+data ForceAuthMethod+ = ForceSecretPost+ | ForceSecretJWT+ | ForcePrivateJWT+ | NoForcedAuth++--------------------------------------------------------------------------------+-- | Command line options.+data Options = Options+ { optionsPort :: Int+ , optionsCert :: FilePath+ , optionsKey :: FilePath+ , optionsForceAuthMode :: ForceAuthMethod+ , optionsProviderUri :: URI+ , optionsClientUri :: URI+ , optionsClientDetails :: ClientDetails+ }++--------------------------------------------------------------------------------+readUri :: O.ReadM URI+readUri = O.eitherReader $ \s ->+ case parseURI s of+ Nothing -> Left "failed to parse URI"+ Just u -> Right u++--------------------------------------------------------------------------------+clientDetails :: O.Parser ClientDetails+clientDetails = register <|> details+ where+ register =+ Register+ <$> O.strOption (mconcat+ [ O.long "register"+ , O.short 'r'+ , O.metavar "EMAIL"+ , O.help "Use dynamic client registration"+ ])++ details =+ Direct+ <$> clientSecretOption+ <*> O.strOption (mconcat+ [ O.long "client-id"+ , O.short 'i'+ , O.metavar "ID"+ , O.help "Provider-assigned client ID"+ ])++ clientSecretOption :: O.Parser ClientSecret+ clientSecretOption =+ AssignedSecretText+ <$> O.strOption (mconcat+ [ O.long "client-secret"+ , O.short 's'+ , O.metavar "STR"+ , O.help "Provider-assigned secret"+ ])++--------------------------------------------------------------------------------+-- | Parse the 'ForceAuthMethod' type from the command line.+forceAuthMode :: O.Parser ForceAuthMethod+forceAuthMode = forceSecretPost+ <|> forceSecretJWT+ <|> forcePrivateJWT+ <|> pure NoForcedAuth+ where+ forceSecretPost =+ O.flag' ForceSecretPost (mconcat+ [ O.long "force-secret-post"+ , O.help "Authenticate via client_secret_post"+ ])++ forceSecretJWT =+ O.flag' ForceSecretJWT (mconcat+ [ O.long "force-secret-jwt"+ , O.help "Authenticate via client_secret_jwt"+ ])++ forcePrivateJWT =+ O.flag' ForcePrivateJWT (mconcat+ [ O.long "force-private-jwt"+ , O.help "Authenticate via private_key_jwt"+ ])++--------------------------------------------------------------------------------+-- | Command line parser.+options :: O.Parser Options+options =+ Options+ <$> O.option O.auto (mconcat+ [ O.long "port"+ , O.metavar "NUM"+ , O.value 3000+ , O.help "Port number for the sever"+ ])++ <*> O.strOption (mconcat+ [ O.long "cert"+ , O.metavar "FILE"+ , O.value "example/cert.pem"+ , O.help "TLS certificate file"+ ])++ <*> O.strOption (mconcat+ [ O.long "key"+ , O.metavar "FILE"+ , O.value "example/key.pem"+ , O.help "TLS private key file"+ ])++ <*> forceAuthMode++ <*> O.option readUri (mconcat+ [ O.long "provider"+ , O.short 'p'+ , O.metavar "URI"+ , O.help "Provider discovery URI"+ ])++ <*> O.option readUri (mconcat+ [ O.long "client-uri"+ , O.short 'c'+ , O.metavar "URI"+ , O.value [uri|https://localhost:0/return|]+ , O.help "The URI for this server, including /return"+ ])++ <*> clientDetails++--------------------------------------------------------------------------------+-- | Parse the command line.+parseOptions :: IO Options+parseOptions = do+ opts <- O.execParser (O.info+ (options O.<**> O.helper)+ (mconcat [ O.fullDesc+ , O.progDesc "OpenID Connect client example"+ ]))++ pure (fixRedirUri opts)+ where+ -- Update the default client URI so the port number matches the server.+ fixRedirUri :: Options -> Options+ fixRedirUri opts =+ case uriAuthority (optionsClientUri opts) of+ Nothing -> opts+ Just auth ->+ if uriRegName auth == "localhost" && uriPort auth == ":0"+ then opts { optionsClientUri = (optionsClientUri opts)+ { uriAuthority = Just auth+ { uriPort = ":" <> show (optionsPort opts)+ }+ }+ }+ else opts
+ example/Util.hs view
@@ -0,0 +1,59 @@+{-|++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/sthenauth/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++-}+module Util+ ( https+ , httpsSimple+ , httpsDebug+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Network.HTTP.Client (Manager, httpLbs)+import qualified Network.HTTP.Client as HTTP+import OpenID.Connect.Client.Flow.AuthorizationCode (HTTPS)+import System.IO++--------------------------------------------------------------------------------+-- | This is the 'HTTPS' function that the openid-connect library+-- needs in order to make HTTP requests.+--+-- Ideally you'd want to handle exceptions here.+httpsSimple :: Manager -> HTTPS IO+httpsSimple mgr = (`httpLbs` mgr)++--------------------------------------------------------------------------------+-- | A function that can make HTTP requests and dump debugging+-- information to STDERR.+httpsDebug :: Manager -> HTTPS IO+httpsDebug mgr request = do+ hPutStrLn stderr "making direct request to the provider:"+ hPrint stderr request++ case HTTP.requestBody request of+ HTTP.RequestBodyLBS bs -> hPrint stderr bs+ HTTP.RequestBodyBS bs -> hPrint stderr bs+ _ -> hPutStrLn stderr "<<body>>"++ res <- httpLbs request mgr+ hPrint stderr res+ hFlush stderr+ pure res++--------------------------------------------------------------------------------+https :: Manager -> HTTPS IO+https = httpsDebug
+ example/certification.sh view
@@ -0,0 +1,224 @@+#! /usr/bin/env nix-shell+#! nix-shell -i bash -p curl+# shellcheck shell=bash++################################################################################+base="https://rp.certification.openid.net:8080"+client="hs-openid-connect"++################################################################################+out=$(pwd)/example+result="$out/result"+server_pid=++if [ ! -d "$out" ]; then+ >&2 echo "ERROR: run this from the top-level directory"+ exit 1+fi++if [ -z "$CLIENT_CONTACT" ]; then+ >&2 echo "Please set CLIENT_CONTACT to an email address"+ exit 1+fi++if [ -d "$result" ]; then+ date=$(date +%Y-%m-%d-%H-%M-%S)+ mv "$result" "$result-$date"+fi++mkdir -p "$result"++################################################################################+stop_server() {+ if [ -n "$server_pid" ]; then+ #echo "stop_server: $server_pid"+ kill -s SIGTERM "$server_pid" > /dev/null 2>&1+ wait "$server_pid" > /dev/null 2>&1+ server_pid=+ fi+}++################################################################################+start_server() {+ path=$1; shift++ ./result/bin/example \+ --provider "$base/$client/$path/.well-known/openid-configuration" \+ --register "$CLIENT_CONTACT" "$@" \+ > "$result/$path.server.stdout" \+ 2> "$result/$path.server.stderr" \+ &+ server_pid=$!++ #echo "start_server: $server_pid"+ sleep 5++ if ! kill -n 0 "$server_pid"; then+ >&2 echo "ERROR: server didn't start"+ server_pid=+ exit 1+ fi+}++################################################################################+# Run curl(1) to make a certification request.+#+# Params:+#+# $1: the URL path+# $2: The test code.+# $3: Expected http status code+# $@: Passed on to curl+_curl() {+ path=$1; shift+ code=$1; shift+ status=$1; shift++ curl \+ --verbose \+ --insecure \+ --location \+ --cookie-jar "$out/cookies" \+ --cookie "$out/cookies" \+ --write-out "%{http_code}" \+ --output "$result/$code.browser.stdout" \+ "$@" "https://localhost:3000/$path" \+ 2>> "$result/$code.browser.stderr" \+ 1> "$result/$code.browers.code"++ actual=$(cat "$result/$code.browers.code")++ if [ "$actual" != "$status" ]; then+ >&2 echo "FAIL: $actual != $status"+ >&2 cat "$result/$code.browser.stdout"+ exit 1+ fi+}++################################################################################+trap stop_server EXIT++################################################################################+basic() {+ test_code=$1; shift+ expect_code=$1; shift++ echo_test "$test_code"+ start_server "$test_code" "$@"+ _curl "login" "$test_code" "$expect_code"+ stop_server+}++################################################################################+echo_profile() { echo "==>" "$@" ; }+echo_group() { echo " *" "$@" ; }+echo_test() { echo " |---->" "$@" ; }+skip() { echo_test "SKIP" "$1" ; }+pass() { echo_test "$@" ; }++################################################################################+# https://rp.certification.openid.net:8080/list?profile=C+profile_code() {+ echo_profile "Profile: Basic RP"++ echo_group "Response Type and Response Mode"+ basic "rp-response_type-code" 200++ echo_group "scope Request Parameter"+ basic "rp-scope-userinfo-claims" 200++ echo_group "nonce Request Parameter"+ basic "rp-nonce-invalid" 403++ echo_group "Client Authentication"+ basic "rp-token_endpoint-client_secret_basic" 200+ skip "rp-token_endpoint-private_key_jwt" 200 --force-private-jwt # FIXME+ basic "rp-token_endpoint-client_secret_post" 200 --force-secret-post+ basic "rp-token_endpoint-client_secret_jwt" 200 --force-secret-jwt++ echo_group "ID Token"+ basic "rp-id_token-kid-absent-single-jwks" 200+ basic "rp-id_token-iat" 403+ basic "rp-id_token-aud" 403+ basic "rp-id_token-kid-absent-multiple-jwks" 200+ basic "rp-id_token-sig-none" 403 # NOTE: spec says this should pass!+ basic "rp-id_token-sig-rs256" 200+ basic "rp-id_token-sub" 403+ basic "rp-id_token-bad-sig-rs256" 403+ basic "rp-id_token-issuer-mismatch" 403+ skip "rp-id_token-sig+enc" 200 --request-token-enc+ skip "rp-id_token-sig-hs256" 200+ basic "rp-id_token-sig-es256" 200+ skip "rp-id_token-sig+enc-a128kw" 200 --request-token-enc+ skip "rp-id_token-bad-sig-hs256" 200+ basic "rp-id_token-bad-sig-es256" 403++ echo_group "UserInfo Endpoint"+ skip "rp-userinfo-bad-sub-claim" # FIXME: REQUIRED+ skip "rp-userinfo-bearer-header" # FIXME: REQUIRED+ skip "rp-userinfo-sig"+ skip "rp-userinfo-bearer-body"+ skip "rp-userinfo-enc"+ skip "rp-userinfo-sig+enc"++ echo_group "Discovery"+ skip "rp-discovery-webfinger-acct"+ skip "rp-discovery-webfinger-http-href"+ skip "rp-discovery-webfinger-url"+ pass "rp-discovery-openid-configuration" # All tests do this+ pass "rp-discovery-jwks_uri-keys" # All tests do this+ skip "rp-discovery-issuer-not-matching-config"+ skip "rp-discovery-webfinger-unknown-member"++ echo_group "Dynamic Client Registration"+ pass "rp-registration-dynamic" # All tests do this++ echo_group "Response Type and Response Mode"+ skip "rp-response_mode-form_post-error"+ skip "rp-response_mode-form_post"++ echo_group "request_uri Request Parameter"+ skip "rp-request_uri-enc"+ skip "rp-request_uri-sig"+ skip "rp-request_uri-sig+enc"+ skip "rp-request_uri-unsigned"++ echo_group "Key Rotation"+ skip "rp-key-rotation-op-sign-key-native"+ skip "rp-key-rotation-op-sign-key"+ skip "rp-key-rotation-op-enc-key"++ echo_group "Claims Types"+ skip "rp-claims-distributed"+ skip "rp-claims-aggregated"++ echo_group "3rd-Party Init SSO"+ skip "rp-3rd_party-init-login"++ echo_group "RP Initiated BackChannel Logout"+ skip "rp-backchannel-rpinitlogout-lt-wrong-issuer"+ skip "rp-backchannel-rpinitlogout-lt-no-event"+ skip "rp-backchannel-rpinitlogout-lt-wrong-aud"+ skip "rp-backchannel-rpinitlogout-lt-with-nonce"+ skip "rp-backchannel-rpinitlogout-lt-wrong-event"+ skip "rp-backchannel-rpinitlogout"+ skip "rp-backchannel-rpinitlogout-lt-wrong-alg"+ skip "rp-backchannel-rpinitlogout-lt-alg-none"++ echo_group "RP Initiated FrontChannel Logout"+ skip "rp-frontchannel-rpinitlogout"+ skip "rp-init-logout-no-state"+ skip "rp-init-logout-other-state"+ skip "rp-init-logout"++ echo_group "Session Management"+ skip "rp-init-logout-session"+}++################################################################################+profile_code++# Local Variables:+# mode: sh+# sh-shell: bash+# End:
+ example/make-tls-certs.sh view
@@ -0,0 +1,22 @@+#!/bin/sh++out="$(pwd)/example"++if [ ! -d "$out" ]; then+ >&2 echo "ERROR: run this from the top-level directory"+ exit 1+fi++openssl genrsa \+ -out "$out/key.pem" \+ 4096++openssl req \+ -batch \+ -new -key "$out/key.pem" \+ -out "$out/cert.csr"++openssl x509 \+ -req -in "$out/cert.csr" \+ -signkey "$out/key.pem" \+ -out "$out/cert.pem"
+ openid-connect.cabal view
@@ -0,0 +1,156 @@+cabal-version: 2.2++--------------------------------------------------------------------------------+name: openid-connect+version: 0.1.0.0+synopsis: An OpenID Connect library that does all the heavy lifting for you+license: BSD-2-Clause+license-file: LICENSE+author: Peter Jones <pjones@devalot.com>+maintainer: Peter Jones <pjones@devalot.com>+copyright: Copyright (c) 2020 Peter Jones+homepage: https://github.com/sthenauth/openid-connect+bug-reports: https://github.com/sthenauth/openid-connect/issues+category: Network++--------------------------------------------------------------------------------+description:+ This package provides an OpenID Connect 1.0 compliant interface for clients and+ some useful types and functions for providers.+ .+ The primary goals of this package are security and usability.+ .+ To get started, take a look at the "OpenID.Connect.Client.Flow.AuthorizationCode"+ module.++--------------------------------------------------------------------------------+extra-source-files:+ README.md+ CHANGES.md+ example/*.sh++--------------------------------------------------------------------------------+flag example+ description: Build the example application+ manual: True+ default: False++--------------------------------------------------------------------------------+common options+ default-language:+ Haskell2010++ ghc-options:+ -Wall+ -Werror=incomplete-record-updates+ -Werror=incomplete-uni-patterns+ -Werror=missing-home-modules+ -Widentities+ -Wmissing-export-lists+ -Wredundant-constraints++--------------------------------------------------------------------------------+common extensions+ default-extensions:+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveFunctor+ DeriveGeneric+ DerivingVia+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators++--------------------------------------------------------------------------------+common dependencies+ build-depends: base >= 4.9 && < 5.0+ , aeson >= 1.3 && < 1.5+ , bytestring >= 0.10 && < 0.11+ , case-insensitive >= 1.2 && < 1.3+ , cookie >= 0.4 && < 0.5+ , cryptonite >= 0.25 && < 1.0+ , http-client >= 0.6 && < 0.7+ , http-types >= 0.12 && < 0.13+ , jose >= 0.8 && < 0.9+ , lens >= 4.0 && < 5.0+ , memory >= 0.14 && < 1.0+ , mtl >= 2.2 && < 2.3+ , network-uri >= 2.6 && < 2.7+ , text >= 1.2 && < 1.3+ , time >= 1.8 && < 2.0+ , unordered-containers >= 0.2 && < 0.3++--------------------------------------------------------------------------------+library+ import: options, extensions, dependencies+ hs-source-dirs: src+ exposed-modules:+ OpenID.Connect.Authentication+ OpenID.Connect.Client.DynamicRegistration+ OpenID.Connect.Client.Flow.AuthorizationCode+ OpenID.Connect.Client.Provider+ OpenID.Connect.Provider.Key+ OpenID.Connect.Scope+ OpenID.Connect.TokenResponse+ other-modules:+ OpenID.Connect.Client.Authentication+ OpenID.Connect.Client.HTTP+ OpenID.Connect.Client.TokenResponse+ OpenID.Connect.Discovery+ OpenID.Connect.JSON+ OpenID.Connect.Registration++--------------------------------------------------------------------------------+executable example+ import: options, extensions, dependencies+ hs-source-dirs: example+ main-is: Main.hs+ other-modules: Auth Discover Options Util++ if !flag(example)+ buildable: False++ build-depends: blaze-html >= 0.9+ , http-client-tls >= 0.3+ , openid-connect >= 0.1+ , optparse-applicative >= 0.14+ , servant >= 0.16+ , servant-blaze >= 0.9+ , servant-server >= 0.16+ , warp >= 3.2+ , warp-tls >= 3.2++--------------------------------------------------------------------------------+test-suite test+ import: options, extensions, dependencies+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: openid-connect+ , tasty >= 1.1 && < 1.3+ , tasty-hunit >= 0.10 && < 0.11++ other-modules:+ Client+ Client.AuthorizationCodeTest+ Client.ProviderTest+ DiscoveryTest+ HttpHelper
+ src/OpenID/Connect/Authentication.hs view
@@ -0,0 +1,185 @@+{-|++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/sthenauth/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++-}+module OpenID.Connect.Authentication+ ( ClientAuthentication(..)+ , ClientSecret(..)+ , Credentials(..)+ , ClientID+ , ClientRedirectURI+ , AuthenticationRequest(..)+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Crypto.JOSE.JWK (JWK)+import Data.ByteString (ByteString)+import Data.Text (Text)+import GHC.Generics (Generic)+import Network.HTTP.Types (QueryItem)+import qualified Network.URI as Network+import OpenID.Connect.JSON+import OpenID.Connect.Scope++--------------------------------------------------------------------------------+-- | Private values needed by the client in order to authenticate with+-- the provider.+--+-- The method of authentication is established when the client+-- registers with the provider.+--+-- @since 0.1.0.0+data ClientSecret+ = AssignedSecretText Text+ -- ^ A @client_secret@ created by the provider and given to the+ -- client to use during authentication.+ --+ -- This is the most common way to authenticate with a provider.++ | AssignedAssertionText Text+ -- ^ A @client_secret@ created by the provider and given to the+ -- client. The client must create a JWT and use the+ -- @client_secret@ to calculate a message authentication code for+ -- the JWT.++ | AssertionPrivateKey JWK+ -- ^ A private key that is solely in the client's possession. The+ -- provider holds the public key portion of the given key.+ --+ -- The client creates and signs a JWT in order to authenticate.++--------------------------------------------------------------------------------+-- | A @client_id@ assigned by the provider.+--+-- @since 0.1.0.0+type ClientID = Text++--------------------------------------------------------------------------------+-- | The client (relying party) redirection URL previously registered+-- with the OpenID Provider (i.e. a URL to an endpoint on your web+-- site that receives authentication details from the provider via the+-- end-user's browser).+--+-- After the provider has authenticated the end-user, they will be+-- redirected to this URL to continue the flow.+--+-- NOTE: This URL must match exactly with the one registered with the+-- provider. If they don't match the provider will not redirect the+-- end-user back to your site.+--+-- @since 0.1.0.0+type ClientRedirectURI = Network.URI++--------------------------------------------------------------------------------+-- | A complete set of credentials used by the client to authenticate+-- with the provider.+--+-- @since 0.1.0.0+data Credentials = Credentials+ { assignedClientId :: ClientID+ -- ^ The provider-assigned @client_id@.++ , clientSecret :: ClientSecret+ -- ^ The @client_secret@ or other means of authenticating.++ , clientRedirectUri :: ClientRedirectURI+ -- ^ The @redirect_uri@ shared between the client and provider.+ -- This URI must be registered with the provider.+ }++--------------------------------------------------------------------------------+-- | §3.1.2.1. Authentication Request.+--+-- The fields of this record are send to the provider by way of a URI+-- given to the end-user.+--+-- Clients can use the+-- 'OpenID.Connect.Client.Flow.AuthorizationCode.defaultAuthenticationRequest'+-- function to easily create a value of this type.+--+-- @since 0.1.0.0+data AuthenticationRequest = AuthenticationRequest+ { authRequestRedirectURI :: ClientRedirectURI+ -- ^ Where to redirect the end-user to after authentication.++ , authRequestClientId :: Text+ -- ^ The @client_id@ assigned by the provider.++ , authRequestScope :: Scope+ -- ^ The @scope@ to request. The @openid@ scope is always part of+ -- this list.++ , authRequestResponseType :: ByteString+ -- ^ The @response_type@ parameter.++ , authRequestDisplay :: Maybe ByteString+ -- ^ The @display@ parameter.++ , authRequestPrompt :: Maybe ByteString+ -- ^ The @prompt@ parameter.++ , authRequestMaxAge :: Maybe Int+ -- ^ The @max_age@ parameter.++ , authRequestUiLocales :: Maybe Words+ -- ^ The @ui_locales@ parameter.++ , authRequestIdTokenHint :: Maybe ByteString+ -- ^ The @id_token_hint@ parameter.++ , authRequestLoginHint :: Maybe Text+ -- ^ The @login_hint@ parameter.++ , authRequestAcrValues :: Maybe Words+ -- ^ The @acr_values@ parameter.++ , authRequestOtherParams :: [QueryItem]+ -- ^ Any additional query parameters you wish to send to the+ -- provider.+ }++--------------------------------------------------------------------------------+-- | Methods that a client can use to authenticate with a provider.+--+-- Defined in OpenID Connect Core 1.0 §9.+--+-- @since 0.1.0.0+data ClientAuthentication+ = ClientSecretBasic+ -- ^ Send credentials using HTTP Basic Authentication.++ | ClientSecretPost+ -- ^ Send the credentials in the body of an HTTP POST.++ | ClientSecretJwt+ -- ^ Create a JWT and calculate a message authentication code+ -- using a shared secret. The JWT confirms that the client is in+ -- possession of the shared secret.++ | PrivateKeyJwt+ -- ^ Create and sign a JWT using a private key. The provider must+ -- already have access to the public key corresponding to the+ -- private key.++ | None+ -- ^ The Client does not authenticate itself at the Token+ -- Endpoint, either because it uses only the Implicit Flow (and so+ -- does not use the Token Endpoint) or because it is a Public+ -- Client with no Client Secret or other authentication mechanism.++ deriving stock (Generic, Eq, Show)+ deriving (ToJSON, FromJSON) via GenericJSON ClientAuthentication
+ src/OpenID/Connect/Client/Authentication.hs view
@@ -0,0 +1,131 @@+{-|++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/sthenauth/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++Client authentication.++-}+module OpenID.Connect.Client.Authentication+ ( applyRequestAuthentication+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Lens ((&), (?~), (.~), (^?), (#))+import Control.Monad.Except+import qualified Crypto.JOSE.Compact as JOSE+import qualified Crypto.JOSE.Error as JOSE+import Crypto.JOSE.JWK (JWK)+import qualified Crypto.JOSE.JWK as JWK+import Crypto.JWT (ClaimsSet)+import qualified Crypto.JWT as JWT+import Crypto.Random (MonadRandom(..))+import Data.ByteArray.Encoding+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.Functor ((<&>))+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import Data.Time.Clock (UTCTime, addUTCTime)+import qualified Network.HTTP.Client as HTTP+import OpenID.Connect.Authentication+import OpenID.Connect.JSON++--------------------------------------------------------------------------------+-- | Modify a request so that it uses the proper authentication method.+applyRequestAuthentication+ :: forall m. MonadRandom m+ => Credentials -- ^ Client credentials.+ -> [ClientAuthentication] -- ^ Available authentication methods.+ -> URI -- ^ Token Endpoint URI+ -> UTCTime -- ^ The current time.+ -> [(ByteString, ByteString)] -- ^ Headers to include in the post.+ -> HTTP.Request -- ^ The request to modify.+ -> m (Maybe HTTP.Request) -- ^ The final request.+applyRequestAuthentication creds methods uri now body =+ case clientSecret creds of+ AssignedSecretText secret+ | ClientSecretBasic `elem` methods -> pure . Just . useBasic secret+ | ClientSecretPost `elem` methods -> pure . Just . useBody secret+ | None `elem` methods -> pure . Just . pass body+ | otherwise -> pure . const Nothing+ AssignedAssertionText key+ | ClientSecretJwt `elem` methods -> hmacWithKey key+ | None `elem` methods -> pure . Just . pass body+ | otherwise -> pure . const Nothing+ AssertionPrivateKey key+ | PrivateKeyJwt `elem` methods -> signWithKey key+ | None `elem` methods -> pure . Just . pass body+ | otherwise -> pure . const Nothing++ where+ pass :: [(ByteString, ByteString)] -> HTTP.Request -> HTTP.Request+ pass = HTTP.urlEncodedBody++ useBody :: Text -> HTTP.Request -> HTTP.Request+ useBody secret = pass+ (body <> [ ("client_secret", Text.encodeUtf8 secret)+ ])++ useBasic :: Text -> HTTP.Request -> HTTP.Request+ useBasic secret =+ HTTP.applyBasicAuth+ (Text.encodeUtf8 (assignedClientId creds))+ (Text.encodeUtf8 secret) . pass body++ -- Use the @client_secret@ as a /key/ to sign a JWT.+ hmacWithKey :: Text -> HTTP.Request -> m (Maybe HTTP.Request)+ hmacWithKey keyBytes =+ signWithKey (JWK.fromOctets (Text.encodeUtf8 keyBytes))++ -- Use the given key to /sign/ a JWT. May create an actual+ -- digital signature or in the case of 'hmacWithKey', create an+ -- HMAC for the header.+ signWithKey :: JWK -> HTTP.Request -> m (Maybe HTTP.Request)+ signWithKey key req = do+ claims <- makeClaims <$> makeJti+ res <- runExceptT $ do+ alg <- JWK.bestJWSAlg key+ JWT.signClaims key (JWT.newJWSHeader ((), alg)) claims+ case res of+ Left (_ :: JOSE.Error) -> pure Nothing+ Right jwt -> pure . Just $ HTTP.urlEncodedBody+ (body <> [ ( "client_assertion_type"+ , "urn:ietf:params:oauth:client-assertion-type:jwt-bearer"+ )+ , ( "client_assertion"+ , LChar8.toStrict (JOSE.encodeCompact jwt)+ )+ ]) req++ -- Claims required by OpenID Connect Core §9.+ makeClaims :: Text -> ClaimsSet+ makeClaims jti+ = JWT.emptyClaimsSet+ & JWT.claimIss .~ assignedClientId creds ^? JWT.stringOrUri+ & JWT.claimSub .~ assignedClientId creds ^? JWT.stringOrUri+ & JWT.claimAud ?~ JWT.Audience (pure (JWT.uri # getURI uri))+ & JWT.claimJti ?~ jti+ & JWT.claimExp ?~ JWT.NumericDate (addUTCTime 60 now)+ & JWT.claimIat ?~ JWT.NumericDate now++ -- JWT ID. From the standard: A unique identifier for the token,+ -- which can be used to prevent reuse of the token.+ makeJti :: m Text+ makeJti = (getRandomBytes 64 :: m ByteString)+ <&> (<> Char8.pack (show now))+ <&> convertToBase Base64URLUnpadded+ <&> Text.decodeUtf8
+ src/OpenID/Connect/Client/DynamicRegistration.hs view
@@ -0,0 +1,77 @@+{-|++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/sthenauth/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++OpenID Connect Dynamic Client Registration 1.0.++-}+module OpenID.Connect.Client.DynamicRegistration+ (+ -- * Registration+ registerClient++ -- * Errors that can occur+ , RegistrationError(..)++ -- * Re-exports+ , HTTPS+ , ErrorResponse(..)+ , module OpenID.Connect.Registration+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Exception (Exception)+import Control.Monad.Except+import Data.Bifunctor (bimap)+import Data.Functor ((<&>))+import OpenID.Connect.Client.HTTP+import OpenID.Connect.Discovery+import OpenID.Connect.JSON+import OpenID.Connect.Registration++--------------------------------------------------------------------------------+-- | Errors that can occur during dynamic client registration.+data RegistrationError+ = NoSupportForRegistrationError+ | RegistrationFailedError ErrorResponse+ deriving (Show, Exception)++--------------------------------------------------------------------------------+-- | Register a client with the provider described by the 'Discovery' document.+--+-- Example:+--+-- @+-- let reg = 'defaultRegistration' yourClientRedirURI+-- metadata = 'clientMetadata' reg 'BasicRegistration'+-- in registerClient http discoveryDoc metadata+-- @+registerClient+ :: (Monad m, ToJSON a, FromJSON a)+ => HTTPS m+ -> Discovery+ -> ClientMetadata a+ -> m (Either RegistrationError (ClientMetadataResponse a))+registerClient https disco meta = runExceptT $ do+ uri <- maybe (throwError NoSupportForRegistrationError) pure+ (registrationEndpoint disco)++ req <- maybe (throwError NoSupportForRegistrationError) pure+ (requestFromURI (Right (getURI uri)))++ ExceptT (https (jsonPostRequest meta req)+ <&> parseResponse+ <&> bimap RegistrationFailedError fst)
+ src/OpenID/Connect/Client/Flow/AuthorizationCode.hs view
@@ -0,0 +1,439 @@+{-|++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/sthenauth/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+ { requestForgeryProtectionToken :: ByteString+ , replayProtectionNonce :: ByteString+ , valueForHttpOnlyCookie :: ByteString+ }++--------------------------------------------------------------------------------+-- | Generate a new set of secrets.+generateRandomSecrets :: forall m. MonadRandom m => m Secrets+generateRandomSecrets = do+ bytes <- getRandomBytes 64 :: m ByteString+ let hash1 = Hash.hash (ByteString.take 32 bytes) :: Hash.Digest Hash.SHA256+ hash2 = Hash.hash (ByteString.drop 32 bytes) :: Hash.Digest Hash.SHA256++ pure Secrets+ { requestForgeryProtectionToken = convertToBase Base64URLUnpadded hash2+ , replayProtectionNonce = convertToBase Base64URLUnpadded hash1+ , valueForHttpOnlyCookie = convertToBase Base64URLUnpadded bytes+ }++--------------------------------------------------------------------------------+-- | Extract the expected state value from the session cookie.+expectedStateParam :: ByteString -> Either FlowError ByteString+expectedStateParam cookie+ = extractTokenFromSessionCookie cookie (ByteString.drop 32)+ & first (const InvalidStateParameterError)++--------------------------------------------------------------------------------+-- | Given the session cookie, return the expected nonce value.+expectedNonce :: ByteString -> Either FlowError Text+expectedNonce cookie+ = extractTokenFromSessionCookie cookie (ByteString.take 32)+ & bimap (const InvalidNonceFromProviderError) 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 cookie f =+ convertFromBase Base64URLUnpadded cookie <&> rehash . f+ where+ rehash :: ByteString -> ByteString+ rehash bs = let hash = Hash.hash bs :: Hash.Digest Hash.SHA256+ in convertToBase Base64URLUnpadded 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 creds =+ AuthenticationRequest+ { authRequestRedirectURI = clientRedirectUri creds+ , authRequestScope = scope+ , authRequestResponseType = "code"+ , authRequestClientId = assignedClientId creds+ , authRequestDisplay = Nothing+ , authRequestPrompt = Nothing+ , authRequestMaxAge = Nothing+ , authRequestUiLocales = Nothing+ , authRequestIdTokenHint = Nothing+ , authRequestLoginHint = Nothing+ , authRequestAcrValues = Nothing+ , 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+ { 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.++ , afterRedirectCodeParam :: ByteString+ -- ^ The @code@ parameter which contains the authorization code.++ , 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 (Show, 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 disco req = do+ let uri = authRequestRedirectURI req+ secrets <- generateRandomSecrets+ makeRedirectURI secrets disco req+ & second (`RedirectTo` makeSessionCookie secrets uri)+ & 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 time (Provider disco keys) creds user = runExceptT $ do+ _ <- ExceptT (pure (verifyPostRedirectRequest user))+ token <- ExceptT (exchangeCodeForIdentityToken https time disco creds user)+ ExceptT (pure (extractClaimsSetFromTokenResponse disco creds token keys time user))++--------------------------------------------------------------------------------+-- | Create the provider authorization redirect URI for the end-user.+makeRedirectURI+ :: Secrets+ -> Discovery+ -> AuthenticationRequest+ -> Either FlowError Network.URI+makeRedirectURI secrets disco AuthenticationRequest{..} =+ let uri = getURI (authorizationEndpoint disco)+ in Right $ uri+ { Network.uriQuery = Char8.unpack+ (renderQuery True (params <> authRequestOtherParams))+ }++ where+ params :: [QueryItem]+ params = filter (isJust . snd)+ [ ("response_type", Just authRequestResponseType)+ , ("client_id", Just (Text.encodeUtf8 authRequestClientId))+ , ("redirect_uri", Just redir)+ , ("nonce", Just (replayProtectionNonce secrets))+ , ("state", Just (requestForgeryProtectionToken secrets))+ , ("display", authRequestDisplay)+ , ("prompt", authRequestPrompt)+ , ("max_age", Char8.pack . show <$> authRequestMaxAge)+ , ("ui_locales", Text.encodeUtf8 . fromWords <$> authRequestUiLocales)+ , ("id_token_hint", authRequestIdTokenHint)+ , ("login_hint", Text.encodeUtf8 <$> authRequestLoginHint)+ , ("acr_values", Text.encodeUtf8 . fromWords <$> authRequestAcrValues)+ , scopeQueryItem authRequestScope+ ]++ redir :: ByteString+ redir = Char8.pack (Network.uriToString id authRequestRedirectURI [])++--------------------------------------------------------------------------------+-- | Create a session cookie for the end-user.+makeSessionCookie :: Secrets -> ClientRedirectURI -> ByteString -> SetCookie+makeSessionCookie Secrets{valueForHttpOnlyCookie} uri name =+ Cookie.defaultSetCookie+ { Cookie.setCookieName = name+ , Cookie.setCookieValue = valueForHttpOnlyCookie+ , Cookie.setCookiePath = Just (Char8.pack (Network.uriPath uri))+ , Cookie.setCookieHttpOnly = True+ , Cookie.setCookieSecure = True+ , Cookie.setCookieSameSite = Just Cookie.sameSiteLax+ }++--------------------------------------------------------------------------------+-- | Validate the @state@ parameter from the end-user.+verifyPostRedirectRequest :: UserReturnFromRedirect -> Either FlowError ()+verifyPostRedirectRequest UserReturnFromRedirect{..} = do+ expectState <- expectedStateParam afterRedirectSessionCookie+ if afterRedirectStateParam == expectState+ then Right ()+ else Left 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 now disco creds user = do+ res <- performRequest+ pure (processResponse =<< res)+ where+ performRequest :: m (Either FlowError (HTTP.Response LByteString.ByteString))+ performRequest = runExceptT $ do+ uri <- maybe+ (throwError ProviderMissingTokenEndpointError) pure+ (tokenEndpoint disco)+ req <- maybe+ (throwError (InvalidProviderTokenEndpointError (uriToText (getURI uri)))) pure+ (requestFromURI (Right (getURI uri)))+ applyRequestAuthentication creds authMethods+ uri now body req >>= \case+ Nothing -> throwError NoAuthenticationMethodsAvailableError+ Just r -> lift (https r)++ processResponse+ :: HTTP.Response LByteString.ByteString+ -> Either FlowError (TokenResponse SignedJWT)+ processResponse res =+ parseResponse res+ & bimap InvalidProviderTokenResponseError fst+ >>= (decodeIdentityToken >>> first TokenDecodingError)++ authMethods :: [ClientAuthentication]+ authMethods = maybe [ClientSecretPost] NonEmpty.toList+ (tokenEndpointAuthMethodsSupported disco)++ body :: [ (ByteString, ByteString) ]+ body = [ ("grant_type", "authorization_code")+ , ("code", afterRedirectCodeParam user)+ , ("redirect_uri", Char8.pack (Network.uriToString id (clientRedirectUri creds) []))+ , ("client_id", Text.encodeUtf8 (assignedClientId 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 disco creds token keys time user = do+ nonce <- expectedNonce (afterRedirectSessionCookie user)+ verifyIdentityTokenClaims disco (assignedClientId creds) time keys nonce token+ & first IdentityTokenValidationFailed
+ src/OpenID/Connect/Client/HTTP.hs view
@@ -0,0 +1,158 @@+{-|++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/sthenauth/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++Helpers for HTTPS.++-}+module OpenID.Connect.Client.HTTP+ ( HTTPS+ , uriToText+ , forceHTTPS+ , requestFromURI+ , addRequestHeader+ , jsonPostRequest+ , cacheUntil+ , parseResponse+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Applicative+import Data.Aeson (ToJSON, FromJSON, eitherDecode)+import qualified Data.Aeson as Aeson+import Data.Bifunctor (bimap)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.CaseInsensitive (CI)+import Data.Char (isDigit)+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Time.Clock (UTCTime, addUTCTime)+import Data.Time.Format (parseTimeM, defaultTimeLocale)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Header as HTTP+import qualified Network.HTTP.Types.Status as HTTP+import Network.URI (URI(..), parseURI, uriToString)+import OpenID.Connect.JSON (ErrorResponse(..))++--------------------------------------------------------------------------------+-- | A function that can make HTTPS requests.+--+-- Make sure you are using a @Manager@ value from the+-- @http-client-tls@ package. It's imperative that the requests+-- flowing through this function are encrypted.+--+-- All requests are set to throw an exception if the response status+-- code is not in the 2xx range. Therefore, functions that take this+-- 'HTTPS' type should be called in an exception-safe way and any+-- exception should be treated as an authentication failure.+--+-- @since 0.1.0.0+type HTTPS m = HTTP.Request -> m (HTTP.Response LByteString.ByteString)++--------------------------------------------------------------------------------+-- | Helper for rendering a URI as Text.+uriToText :: URI -> Text+uriToText uri = Text.pack (uriToString id uri [])++--------------------------------------------------------------------------------+-- | Force the given URI to use HTTPS.+forceHTTPS :: URI -> URI+forceHTTPS uri = uri { uriScheme = "https:" }++--------------------------------------------------------------------------------+-- | Convert a URI or Text value into a pre-configured request object.+requestFromURI :: Either Text URI -> Maybe HTTP.Request+requestFromURI (Left t) = parseURI (Text.unpack t) >>= requestFromURI . Right+requestFromURI (Right uri) =+ HTTP.requestFromURI (forceHTTPS uri)+ <&> addRequestHeader ("Accept", "application/json")++--------------------------------------------------------------------------------+-- | Add a JSON body to a request.+jsonPostRequest :: ToJSON a => a -> HTTP.Request -> HTTP.Request+jsonPostRequest json req = addRequestHeader ("Content-Type", "application/json") $+ req { HTTP.method = "POST"+ , HTTP.requestBody = HTTP.RequestBodyLBS (Aeson.encode json)+ }++--------------------------------------------------------------------------------+-- | Add a header to the request.+addRequestHeader :: (CI ByteString, ByteString) -> HTTP.Request -> HTTP.Request+addRequestHeader header req =+ req { HTTP.requestHeaders =+ header : filter ((/= fst header) . fst) (HTTP.requestHeaders req)+ }++--------------------------------------------------------------------------------+-- | Given a response, calculate how long it can be cached.+cacheUntil :: HTTP.Response a -> Maybe UTCTime+cacheUntil res = maxAge <|> expires+ where+ parseTime :: ByteString -> Maybe UTCTime+ parseTime = parseTimeM True defaultTimeLocale rfc1123 . Char8.unpack++ rfc1123 :: String+ rfc1123 = "%a, %d %b %Y %X %Z"++ date :: Maybe UTCTime+ date = lookup HTTP.hDate (HTTP.responseHeaders res) >>= parseTime++ expires :: Maybe UTCTime+ expires = lookup HTTP.hExpires (HTTP.responseHeaders res) >>= parseTime++ maxAge :: Maybe UTCTime+ maxAge = do+ dt <- date+ bs <- lookup HTTP.hCacheControl (HTTP.responseHeaders res)+ ma <- nullM (snd (Char8.breakSubstring "max-age" bs))+ bn <- nullM (snd (Char8.break isDigit ma))+ addUTCTime . fromIntegral . fst+ <$> Char8.readInt (Char8.take 6 bn) -- Limit input to readInt+ <*> pure dt++ nullM :: ByteString -> Maybe ByteString+ nullM bs = if Char8.null bs then Nothing else Just bs++--------------------------------------------------------------------------------+-- | Decode the JSON body of a request and calculate how long it can+-- be cached.+parseResponse+ :: FromJSON a+ => HTTP.Response LByteString.ByteString+ -> Either ErrorResponse (a, Maybe UTCTime)+parseResponse response =+ if HTTP.statusIsSuccessful (HTTP.responseStatus response)+ then eitherDecode (HTTP.responseBody response) &+ bimap asError (,cacheUntil response)+ else Left (asError "invalid response from server")+ where+ asError :: String -> ErrorResponse+ asError s = case eitherDecode (HTTP.responseBody response) of+ Left _ -> ErrorResponse (Text.pack s) (Just bodyError)+ Right e -> e++ bodyError :: Text+ bodyError = response+ & HTTP.responseBody+ & LChar8.take 1024+ & LChar8.toStrict+ & Text.decodeUtf8
+ src/OpenID/Connect/Client/Provider.hs view
@@ -0,0 +1,150 @@+{-|++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/sthenauth/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++Provider details needed by clients.++-}+module OpenID.Connect.Client.Provider+ (+ -- * Provider discovery+ ProviderDiscoveryURI+ , discovery++ -- * Provider key sets+ , keysFromDiscovery++ -- * Provider convenience record+ , Provider(..)+ , discoveryAndKeys++ -- * Error handling+ , DiscoveryError(..)++ -- * Discovery document+ , Discovery(..)++ -- * Re-exports:+ , URI(..)+ , uriToText+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Exception (Exception)+import Control.Monad.Except (ExceptT(..), runExceptT)+import Crypto.JOSE.JWK (JWKSet)+import Data.Bifunctor (first)+import Data.Functor ((<&>))+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import qualified Network.URI as Network+import OpenID.Connect.Client.HTTP+import OpenID.Connect.Discovery+import OpenID.Connect.JSON++--------------------------------------------------------------------------------+-- | Errors that may occur during provider discovery.+--+-- @since 0.1.0.0+data DiscoveryError+ = DiscoveryFailedError ErrorResponse+ -- ^ Failed to decode JSON from the provider.++ | InvalidUriError Text+ -- ^ A provider's URI is invalid. The URI is provided as 'Text'+ -- for debugging purposes.++ deriving (Show, Exception)++--------------------------------------------------------------------------------+-- | A provider record is made up of their discovery document and keys.+--+-- @since 0.1.0.0+data Provider = Provider+ { providerDiscovery :: Discovery -- ^ Details from the discovery URI.+ , providerKeys :: JWKSet -- ^ Keys from the @jwksUri@.+ }++--------------------------------------------------------------------------------+-- | Fetch the provider's discovery document.+--+-- Included with the discovery document is a 'UTCTime' value+-- indicating the time at which the content will expire and should be+-- expunged from your cache. Obviously 'Nothing' indicates that the+-- value cannot be cached.+--+-- If the given 'ProviderDiscoveryURI' is missing its @path@+-- component, or the @path@ component is @/@ it will be rewritten to+-- the /well-known/ discovery path.+--+-- @since 0.1.0.0+discovery+ :: Applicative f+ => HTTPS f -- ^ A function that can make HTTPS requests.+ -> ProviderDiscoveryURI -- ^ The provider's discovery URI.+ -> f (Either DiscoveryError (Discovery, Maybe UTCTime))+discovery https uri =+ case requestFromURI (Right (setPath uri)) of+ Nothing -> pure (Left (InvalidUriError (uriToText uri)))+ Just req -> https req <&> parseResponse <&> first DiscoveryFailedError+ where+ setPath :: Network.URI -> Network.URI+ setPath u@Network.URI{uriPath} =+ if null uriPath || uriPath == "/"+ then u {Network.uriPath = "/.well-known/openid-configuration"}+ else u++--------------------------------------------------------------------------------+-- | Fetch the provider's key set.+--+-- Included with the key set is a 'UTCTime' value indicating the time+-- at which the content will expire and should be expunged from your+-- cache.+--+-- @since 0.1.0.0+keysFromDiscovery+ :: Applicative f+ => HTTPS f -- ^ A function that can make HTTPS requests.+ -> Discovery -- ^ The provider's discovery document.+ -> f (Either DiscoveryError (JWKSet, Maybe UTCTime))+keysFromDiscovery https Discovery{jwksUri} =+ case requestFromURI (Right (getURI jwksUri)) of+ Nothing -> pure (Left (InvalidUriError (uriToText (getURI jwksUri))))+ Just req -> https req <&> parseResponse <&> first DiscoveryFailedError++--------------------------------------------------------------------------------+-- | Fetch a provider's discovery document and key set.+--+-- This is a convenience function that simply calls 'discovery' and+-- 'keysFromDiscovery', wrapping them in a 'Provider'.+--+-- If you are caching the results of these functions you probably want+-- to call them individually since they might have very different+-- cache expiration times.+--+-- The expiration time returned from this function is the lesser of+-- the two constituents.+--+-- @since 0.1.0.0+discoveryAndKeys+ :: Monad m+ => HTTPS m -- ^ A function that can make HTTPS requests.+ -> ProviderDiscoveryURI -- ^ The provider's discovery URI.+ -> m (Either DiscoveryError (Provider, Maybe UTCTime))+discoveryAndKeys https uri = runExceptT $ do+ (d, t1) <- ExceptT (discovery https uri )+ (k, t2) <- ExceptT (keysFromDiscovery https d)+ pure (Provider d k, min <$> t1 <*> t2)
+ src/OpenID/Connect/Client/TokenResponse.hs view
@@ -0,0 +1,143 @@+{-|++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/sthenauth/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++-}+module OpenID.Connect.Client.TokenResponse+ ( decodeIdentityToken+ , verifyIdentityTokenClaims+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Lens ((^.), (.~), (^?), (#))+import Control.Monad.Except+import Control.Monad.Reader+import qualified Crypto.JOSE.Compact as JOSE+import qualified Crypto.JOSE.Error as JOSE+import Crypto.JWT as JWT+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.Function ((&))+import Data.Functor.Identity+import qualified Data.HashMap.Strict as Map+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import Data.Time.Clock (UTCTime)+import OpenID.Connect.Authentication (ClientID)+import OpenID.Connect.Client.Provider+import OpenID.Connect.TokenResponse++--------------------------------------------------------------------------------+-- | Decode the compacted identity token into a 'SignedJWT'.+decodeIdentityToken+ :: TokenResponse Text+ -> Either JOSE.Error (TokenResponse SignedJWT)+decodeIdentityToken token+ = JOSE.decodeCompact (LChar8.fromStrict (Text.encodeUtf8 (idToken token)))+ & runExceptT+ & runIdentity+ & fmap (<$ token)++--------------------------------------------------------------------------------+-- | Identity token verification and claim validation.+verifyIdentityTokenClaims+ :: Discovery -- ^ Provider discovery document.+ -> ClientID -- ^ Intended audience.+ -> UTCTime -- ^ Current time.+ -> JWKSet -- ^ Available keys to try.+ -> Text -- ^ Nonce.+ -> TokenResponse SignedJWT -- ^ Signed identity token.+ -> Either JWTError (TokenResponse ClaimsSet)+verifyIdentityTokenClaims disco clientId now keys nonce token =+ let JWKSet jwks = keys+ in foldr (\k -> either (const (verifyWithKey k)) Right)+ (Left (JWT.JWSError JOSE.NoUsableKeys)) jwks+ where+ verifyWithKey :: JWK -> Either JWTError (TokenResponse ClaimsSet)+ verifyWithKey key =+ let settings = JWT.defaultJWTValidationSettings (const True)+ & allowedSkew .~ 120+ & issuerPredicate .~ verifyIssuer+ & checkIssuedAt .~ True+ in JWT.verifyClaimsAt settings key now (idToken token)+ & runExceptT+ & runIdentity >>= additionalValidation clientId nonce+ & fmap (<$ token)++ verifyIssuer :: JWT.StringOrURI -> Bool+ verifyIssuer = (== (JWT.uri # getURI (issuer disco)))++-- FIXME: validate the at_hash+-- FIXME: rp-id_token-bad-sig-hs256 (Request an ID token and verify+-- its signature using the 'client_secret' as MAC key.)++--------------------------------------------------------------------------------+type Validate a = ExceptT JWTError (ReaderT ClaimsSet Identity) a++--------------------------------------------------------------------------------+orFailWith :: (ClaimsSet -> Bool) -> JWTError -> Validate ()+orFailWith f e = do+ claims <- ask+ if f claims then pure () else throwError e++--------------------------------------------------------------------------------+claimEq :: Text -> Aeson.Value -> ClaimsSet -> Bool+claimEq key val claims =+ case Map.lookup key (claims ^. JWT.unregisteredClaims) of+ Nothing -> False+ Just val' -> val == val'++--------------------------------------------------------------------------------+additionalValidation :: ClientID -> Text -> ClaimsSet -> Either JWTError ClaimsSet+additionalValidation clientId nonce = go+ where+ go :: ClaimsSet -> Either JWTError ClaimsSet+ go claims = checks+ & runExceptT+ & flip runReaderT claims+ & runIdentity+ & (claims <$)++ checks :: Validate ()+ checks = do+ verifyNonce `orFailWith` JWT.JWTClaimsSetDecodeError "invalid nonce"+ verifyIat `orFailWith` JWT.JWTIssuedAtFuture+ verifySub `orFailWith` JWT.JWTClaimsSetDecodeError "missing subject"+ (\c -> verifyAudience c ||+ verifyAzp c) `orFailWith` JWT.JWTNotInAudience++ verifyNonce :: ClaimsSet -> Bool+ verifyNonce = claimEq "nonce" (Aeson.String nonce)++ verifyAudience :: ClaimsSet -> Bool+ verifyAudience claims =+ case claims ^. claimAud of+ Just (JWT.Audience [aud]) ->+ Just aud == clientId ^? JWT.stringOrUri+ _ -> False++ verifyAzp :: ClaimsSet -> Bool+ verifyAzp = claimEq "azp" (Aeson.String clientId)++ verifySub :: ClaimsSet -> Bool+ verifySub = isJust . (^. claimSub)++ -- JOSE verifies the iat claim if it exists but does not reject if+ -- the iat is missing. OpenID Connect requires a rejection when+ -- iat is missing.+ verifyIat :: ClaimsSet -> Bool+ verifyIat = isJust . (^. claimIat)
+ src/OpenID/Connect/Discovery.hs view
@@ -0,0 +1,214 @@+{-|++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/sthenauth/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++-}+module OpenID.Connect.Discovery+ ( Discovery(..)+ , ProviderDiscoveryURI+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import GHC.Generics (Generic)+import qualified Network.URI as Network+import OpenID.Connect.Authentication+import OpenID.Connect.JSON+import OpenID.Connect.Scope++--------------------------------------------------------------------------------+-- | URI pointing to an OpenID Connect provider's discovery document.+--+-- If necessary, the /well-known/ discovery path will be added+-- automatically.+--+-- A list of certified OpenID Connect providers can be found here:+-- <https://openid.net/certification/>+--+-- @since 0.1.0.0+type ProviderDiscoveryURI = Network.URI++--------------------------------------------------------------------------------+-- | The provider discovery document as specified in+-- /OpenID Connect Discovery 1.0/ §3.+--+-- @since 0.1.0.0+data Discovery = Discovery+ { issuer :: URI+ -- ^ URL using the https scheme with no query or fragment+ -- component that the OP asserts as its Issuer Identifier.++ , authorizationEndpoint :: URI+ -- ^ URL of the OP's OAuth 2.0 Authorization Endpoint.++ , tokenEndpoint :: Maybe URI+ -- ^ URL of the OP's OAuth 2.0 Token Endpoint. Not provided when+ -- using the implicit flow.++ , userinfoEndpoint :: Maybe URI+ -- ^ URL of the OP's UserInfo Endpoint.++ , jwksUri :: URI+ -- ^ URL of the OP's JSON Web Key Set document.++ , registrationEndpoint :: Maybe URI+ -- ^ URL of the OP's Dynamic Client Registration Endpoint.++ , scopesSupported :: Maybe Scope+ -- ^ List of OAuth 2.0 scope values that this server supports.++ , responseTypesSupported :: NonEmpty Text+ -- ^ Array containing a list of the OAuth 2.0 @response_type@+ -- values that this OP supports.++ , responseModesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the OAuth 2.0 response_mode+ -- values that this OP supports.++ , grantTypesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the OAuth 2.0 Grant Type+ -- values that this OP supports.++ , acrValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the Authentication Context+ -- Class References that this OP supports.++ , subjectTypesSupported :: NonEmpty Text+ -- ^ JSON array containing a list of the Subject Identifier types+ -- that this OP supports.++ , idTokenSigningAlgValuesSupported :: NonEmpty Text+ -- ^ JSON array containing a list of the JWS signing algorithms+ -- (alg values) supported by the OP for the ID Token to encode the+ -- Claims in a JWT.++ , idTokenEncryptionAlgValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the JWE encryption algorithms+ -- (alg values) supported by the OP for the ID Token to encode the+ -- Claims in a JWT.++ , idTokenEncryptionEncValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the JWE encryption algorithms+ -- (enc values) supported by the OP for the ID Token to encode the+ -- Claims in a JWT.++ , userinfoSigningAlgValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the JWS signing algorithms+ -- (alg values).++ , userinfoEncryptionAlgValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the JWE encryption algorithms+ -- (alg values).++ , userinfoEncryptionEncValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the JWE encryption algorithms+ -- (enc values).++ , requestObjectSigningAlgValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the JWS signing algorithms+ -- (alg values) supported by the OP for Request Objects, which are+ -- described in Section 6.1 of OpenID Connect Core 1.0.++ , requestObjectEncryptionAlgValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the JWE encryption algorithms+ -- (alg values) supported by the OP for Request Objects. These+ -- algorithms are used both when the Request Object is passed by+ -- value and when it is passed by reference.++ , requestObjectEncryptionEncValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the JWE encryption algorithms+ -- (enc values) supported by the OP for Request Objects. These+ -- algorithms are used both when the Request Object is passed by+ -- value and when it is passed by reference.++ , tokenEndpointAuthMethodsSupported :: Maybe (NonEmpty ClientAuthentication)+ -- ^ JSON array containing a list of Client Authentication methods+ -- supported by this Token Endpoint.++ , tokenEndpointAuthSigningAlgValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the JWS signing algorithms+ -- (alg values) supported by the Token Endpoint for the signature+ -- on the JWT used to authenticate the Client at the Token+ -- Endpoint for the private_key_jwt and client_secret_jwt+ -- authentication methods.++ , displayValuesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the display parameter values+ -- that the OpenID Provider supports. These values are described+ -- in Section 3.1.2.1 of OpenID Connect Core 1.0.++ , claimTypesSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the Claim Types+ -- that the OpenID Provider supports. These Claim Types are+ -- described in Section 5.6 of OpenID Connect Core 1.0.++ , claimsSupported :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the Claim Names of the Claims+ -- that the OpenID Provider MAY be able to supply values for. Note+ -- that for privacy or other reasons, this might not be an+ -- exhaustive list.++ , serviceDocumentation :: Maybe Text+ -- ^ URL of a page containing human-readable information that+ -- developers might want or need to know when using the OpenID+ -- Provider. In particular, if the OpenID Provider does not+ -- support Dynamic Client Registration, then information on how to+ -- register Clients needs to be provided in this documentation.++ , claimsLocalesSupported :: Maybe (NonEmpty Text)+ -- ^ Languages and scripts supported for values in Claims being+ -- returned, represented as a JSON array of language tag+ -- values. Not all languages and scripts are necessarily supported+ -- for all Claim values.++ , claimsParameterSupported :: Maybe Bool+ -- ^ Boolean value specifying whether the OP supports use of the+ -- claims parameter, with true indicating support. If omitted, the+ -- default value is false.++ , requestParameterSupported :: Maybe Bool+ -- ^ Boolean value specifying whether the OP supports use of the+ -- request parameter, with true indicating support. If omitted,+ -- the default value is false.++ , requestUriParameterSupported :: Maybe Bool+ -- ^ Boolean value specifying whether the OP supports use of the+ -- request_uri parameter, with true indicating support. If+ -- omitted, the default value is true.++ , requireRequestUriRegistration :: Maybe Bool+ -- ^ Boolean value specifying whether the OP requires any+ -- request_uri values used to be pre-registered using the+ -- request_uris registration parameter. Pre-registration is+ -- REQUIRED when the value is true. If omitted, the default value+ -- is false.++ , opPolicyUri :: Maybe URI+ -- ^ URL that the OpenID Provider provides to the person+ -- registering the Client to read about the OP's requirements on+ -- how the Relying Party can use the data provided by the OP. The+ -- registration process SHOULD display this URL to the person+ -- registering the Client if it is given.++ , opTosUri :: Maybe URI+ -- ^ URL that the OpenID Provider provides to the person+ -- registering the Client to read about OpenID Provider's terms of+ -- service. The registration process SHOULD display this URL to+ -- the person registering the Client if it is given.+ }+ deriving stock (Generic, Show)+ deriving (ToJSON, FromJSON) via GenericJSON Discovery
+ src/OpenID/Connect/JSON.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE UndecidableInstances #-}++{-|++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/sthenauth/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++-}+module OpenID.Connect.JSON+ ( GenericJSON(..)+ , ErrorResponse(..)+ , (:*:)(..)+ , Words(..)+ , fromWords+ , toWords+ , URI(..)+ , Aeson.ToJSON+ , Aeson.FromJSON+ ) where++--------------------------------------------------------------------------------+import Control.Category ((>>>))+import Control.Monad (MonadPlus(..))+import Data.Aeson as Aeson+import Data.Aeson.Encoding as Aeson+import Data.Bifunctor (bimap)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic, Rep)+import qualified Network.URI as Network++--------------------------------------------------------------------------------+-- | Type wrapper for automatic JSON deriving.+newtype GenericJSON a = GenericJSON+ { genericJSON :: a }++--------------------------------------------------------------------------------+-- | Default JSON decoding/encoding options.+aesonOptions :: Aeson.Options+aesonOptions = Aeson.defaultOptions+ { Aeson.fieldLabelModifier = snakeCase+ , Aeson.constructorTagModifier = snakeCase+ , Aeson.allNullaryToStringTag = True+ , Aeson.omitNothingFields = True+ }+ where+ snakeCase = Aeson.camelTo2 '_' . dropWhile (== '_')++instance ( Generic a+ , Aeson.GToJSON Aeson.Zero (Rep a)+ , Aeson.GToEncoding Aeson.Zero (Rep a)+ ) =>+ ToJSON (GenericJSON a) where+ toJSON = Aeson.genericToJSON aesonOptions . genericJSON+ toEncoding = Aeson.genericToEncoding aesonOptions . genericJSON++instance ( Generic a+ , Aeson.GFromJSON Aeson.Zero (Rep a)+ ) =>+ FromJSON (GenericJSON a) where+ parseJSON = fmap GenericJSON . Aeson.genericParseJSON aesonOptions++--------------------------------------------------------------------------------+-- | A provider response that indicates an error as described in OAuth+-- 2.0 Bearer Token Usage (RFC 6750).+--+-- @since 0.1.0.0+data ErrorResponse = ErrorResponse+ { errorCode :: Text+ , errorDescription :: Maybe Text+ }+ deriving stock Show++instance ToJSON ErrorResponse where+ toJSON ErrorResponse{..} = Aeson.object+ [ "error" .= errorCode+ , "error_description" .= errorDescription+ ]+ toEncoding ErrorResponse{..} = Aeson.pairs+ ( "error" .= errorCode <> "error_description" .= errorDescription)++instance FromJSON ErrorResponse where+ parseJSON = Aeson.withObject "Error Response" $ \v ->+ ErrorResponse+ <$> v .: "error"+ <*> v .:? "error_description"++--------------------------------------------------------------------------------+-- | Join two types together so they work with the same JSON document.+newtype (:*:) a b = Join+ { getProduct :: (a, b) }++instance (ToJSON a, ToJSON b) => ToJSON (a :*: b) where+ toJSON prod =+ case bimap toJSON toJSON (getProduct prod) of+ (Aeson.Object x, Aeson.Object y) -> Aeson.Object (x <> y)+ (x, _) -> x++instance (FromJSON a, FromJSON b) => FromJSON (a :*: b) where+ parseJSON v = fmap Join ((,) <$> parseJSON v <*> parseJSON v)++--------------------------------------------------------------------------------+-- | Space separated list of words.+--+-- @since 0.1.0.0+newtype Words = Words+ { toWordList :: NonEmpty Text+ }+ deriving stock (Generic, Show)+ deriving newtype Semigroup++instance ToJSON Words where+ toJSON = fromWords >>> toJSON+ toEncoding = fromWords >>> toEncoding++instance FromJSON Words where+ parseJSON = Aeson.withText "Space separated words" toWords++--------------------------------------------------------------------------------+-- | Encode a list of words into 'Text'.+--+-- @since 0.1.0.0+fromWords :: Words -> Text+fromWords = toWordList+ >>> NonEmpty.nub+ >>> NonEmpty.toList+ >>> Text.unwords++--------------------------------------------------------------------------------+-- | Decode a list of words from 'Text'.+--+-- @since 0.1.0.0+toWords :: MonadPlus m => Text -> m Words+toWords = Text.words >>> \case+ [] -> mzero+ xs -> pure (Words $ NonEmpty.fromList xs)++--------------------------------------------------------------------------------+-- | A wrapper around the "Network.URI" type that supports 'ToJSON'+-- and 'FromJSON'.+--+-- @since 0.1.0.0+newtype URI = URI+ { getURI :: Network.URI }+ deriving newtype (Show, Eq)++instance ToJSON URI where+ toJSON u = toJSON (Network.uriToString id (getURI u) [])+ toEncoding u = Aeson.string (Network.uriToString id (getURI u) [])++instance FromJSON URI where+ parseJSON = Aeson.withText "URI" go+ where+ go = maybe mzero (pure . URI) .+ Network.parseURI .+ Text.unpack
+ src/OpenID/Connect/Provider/Key.hs view
@@ -0,0 +1,76 @@+{-|++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/sthenauth/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++-}+module OpenID.Connect.Provider.Key+ (+ -- * Generating Keys+ newJWK+ , newSigningJWK+ , newEncryptionJWK+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Lens ((^.), (?~), re)+import Crypto.Hash (Digest, SHA256)+import Crypto.JOSE (JWK, KeyUse(..))+import qualified Crypto.JOSE as JOSE+import qualified Crypto.JOSE.JWA.JWE.Alg as JOSE+import Crypto.Random (MonadRandom)+import Data.Function ((&))+import Data.Text (Text)+import Data.Text.Strict.Lens (utf8)++--------------------------------------------------------------------------------+-- | An opinionated way of creating a 'JWK'. For more control over+-- how the key is crated use 'JOSE.genJWK' instead.+--+-- Returns the new key and the key's ID.+--+-- @since 0.1.0.0+newJWK :: MonadRandom m => KeyUse -> m (JWK, Text)+newJWK keyuse = do+ jwk <- JOSE.genJWK (JOSE.RSAGenParam (4096 `div` 8))++ let h = jwk ^. JOSE.thumbprint :: Digest SHA256+ kid = h ^. (re (JOSE.base64url . JOSE.digest) . utf8)+ final = jwk+ & JOSE.jwkKid ?~ kid+ & JOSE.jwkUse ?~ keyuse+ & JOSE.jwkAlg ?~ alg keyuse++ pure (final, kid)++ where+ alg :: KeyUse -> JOSE.JWKAlg+ alg = \case+ Sig -> JOSE.JWSAlg JOSE.RS256+ Enc -> JOSE.JWEAlg JOSE.A256KW++--------------------------------------------------------------------------------+-- | Created a new signing key.+--+-- @since 0.1.0.0+newSigningJWK :: MonadRandom m => m JWK+newSigningJWK = fst <$> newJWK Sig++--------------------------------------------------------------------------------+-- | Create a new encryption key.+--+-- @since 0.1.0.0+newEncryptionJWK :: MonadRandom m => m JWK+newEncryptionJWK = fst <$> newJWK Enc
+ src/OpenID/Connect/Registration.hs view
@@ -0,0 +1,329 @@+{-|++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/sthenauth/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++OpenID Connect Dynamic Client Registration 1.0.++-}+module OpenID.Connect.Registration+ ( Registration(..)+ , defaultRegistration+ , ClientMetadata+ , BasicRegistration(..)+ , clientMetadata+ , RegistrationResponse(..)+ , ClientMetadataResponse+ , clientSecretsFromResponse+ , additionalMetadataFromResponse+ , registrationFromResponse+ , (:*:)+ , URI(..)+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Crypto.JOSE (JWKSet)+import qualified Crypto.JOSE.JWA.JWE.Alg as JWE+import qualified Crypto.JOSE.JWA.JWS as JWS+import Crypto.JWT (NumericDate)+import qualified Data.Aeson as Aeson+import Data.List.NonEmpty (NonEmpty(..))+import Data.Text (Text)+import GHC.Generics (Generic)+import qualified Network.URI as Network+import OpenID.Connect.Authentication+import OpenID.Connect.JSON++--------------------------------------------------------------------------------+-- | Client registration metadata.+--+-- OpenID Connect Dynamic Client Registration 1.0 §2.+--+-- Use the 'defaultRegistration' function to easily create a value of+-- this type.+data Registration = Registration+ { redirectUris :: NonEmpty URI+ -- ^ Array of Redirection URI values used by the Client.++ , responseTypes :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the OAuth 2.0 response_type+ -- values that the Client is declaring that it will restrict+ -- itself to using.++ , grantTypes :: Maybe (NonEmpty Text)+ -- ^ JSON array containing a list of the OAuth 2.0 Grant Types+ -- that the Client is declaring that it will restrict itself to+ -- using.++ , applicationType :: Maybe Text+ -- ^ Kind of the application. The default, if omitted, is web. The+ -- defined values are native or web.++ , contacts :: Maybe (NonEmpty Text)+ -- ^ Array of e-mail addresses of people responsible for this Client.++ , clientName :: Maybe Text+ -- ^ Name of the Client to be presented to the End-User.++ , logoUri :: Maybe URI+ -- ^ URL that references a logo for the Client application.++ , clientUri :: Maybe URI+ -- ^ URL of the home page of the Client.++ , policyUri :: Maybe URI+ -- ^ URL that the Relying Party Client provides to the End-User to+ -- read about the how the profile data will be used.++ , tosUri :: Maybe URI+ -- ^ URL that the Relying Party Client provides to the End-User to+ -- read about the Relying Party's terms of service.++ , jwksUri :: Maybe URI+ -- ^ URL for the Client's JSON Web Key Set document.++ , jwks :: Maybe JWKSet+ -- ^ Client's JSON Web Key Set [JWK] document, passed by value.++ , sectorIdentifierUri :: Maybe URI+ -- ^ URL using the https scheme to be used in calculating+ -- Pseudonymous Identifiers by the OP.++ , subjectType :: Maybe Text+ -- ^ @subject_type@ requested for responses to this Client.++ , idTokenSignedResponseAlg :: Maybe JWS.Alg+ -- ^ JWS alg algorithm required for signing the ID Token issued to+ -- this Client.++ , idTokenEncryptedResponseAlg :: Maybe JWE.Alg+ -- ^ JWE alg algorithm required for encrypting the ID Token issued+ -- to this Client.++ , idTokenEncryptedResponseEnc :: Maybe JWE.Alg+ -- ^ JWE enc algorithm required for encrypting the ID Token issued+ -- to this Client.++ , userinfoSignedResponseAlg :: Maybe JWS.Alg+ -- ^ JWS alg algorithm [JWA] REQUIRED for signing UserInfo+ -- Responses.++ , userinfoEncryptedResponseAlg :: Maybe JWE.Alg+ -- ^ JWE alg algorithm required for encrypting UserInfo Responses.++ , userinfoEncryptedResponseEnc :: Maybe JWE.Alg+ -- ^ JWE enc algorithm required for encrypting UserInfo Responses.++ , requestObjectSigningAlg :: Maybe JWS.Alg+ -- ^ JWS alg algorithm that must be used for signing Request+ -- Objects sent to the OP.++ , requestObjectEncryptionAlg :: Maybe JWE.Alg+ -- ^ JWE alg algorithm the RP is declaring that it may use for+ -- encrypting Request Objects sent to the OP. This parameter+ -- SHOULD be included when symmetric encryption will be used,+ -- since this signals to the OP that a @client_secret@ value needs+ -- to be returned from which the symmetric key will be derived,+ -- that might not otherwise be returned. The RP MAY still use+ -- other supported encryption algorithms or send unencrypted+ -- Request Objects, even when this parameter is present. If both+ -- signing and encryption are requested, the Request Object will+ -- be signed then encrypted, with the result being a Nested JWT,+ -- as defined in JWT. The default, if omitted, is that the RP is+ -- not declaring whether it might encrypt any Request Objects.++ , requestObjectEncryptionEnc :: Maybe JWE.Alg+ -- ^ JWE enc algorithm the RP is declaring that it may use for+ -- encrypting Request Objects sent to the OP. If+ -- @request_object_encryption_alg@ is specified, the default for+ -- this value is @A128CBC-HS256@. When+ -- @request_object_encryption_enc@ is included,+ -- @request_object_encryption_alg@ MUST also be provided.++ , tokenEndpointAuthMethod :: ClientAuthentication+ -- ^ Requested Client Authentication method for the Token+ -- Endpoint.++ , tokenEndpointAuthSigningAlg :: Maybe JWS.Alg+ -- ^ JWS alg algorithm that must be used for signing the JWT used+ -- to authenticate the Client at the Token Endpoint for the+ -- private_key_jwt and client_secret_jwt authentication methods.++ , defaultMaxAge :: Maybe Int+ -- ^ Default Maximum Authentication Age. Specifies that the+ -- End-User MUST be actively authenticated if the End-User was+ -- authenticated longer ago than the specified number of seconds.++ , requireAuthTime :: Maybe Bool+ -- ^ Boolean value specifying whether the auth_time Claim in the+ -- ID Token is REQUIRED. It is REQUIRED when the value is+ -- true. (If this is false, the auth_time Claim can still be+ -- dynamically requested as an individual Claim for the ID Token+ -- using the claims request parameter described in Section 5.5.1+ -- of OpenID Connect Core 1.0.) If omitted, the default value is+ -- false.++ , defaultAcrValues :: Maybe (NonEmpty Text)+ -- ^ Default requested Authentication Context Class Reference+ -- values. Array of strings that specifies the default acr values+ -- that the OP is being requested to use for processing requests+ -- from this Client, with the values appearing in order of+ -- preference.++ , initiateLoginUri :: Maybe URI+ -- ^ URI using the https scheme that a third party can use to+ -- initiate a login by the RP, as specified in Section 4 of OpenID+ -- Connect Core 1.0. The URI MUST accept requests via both GET and+ -- POST. The Client MUST understand the login_hint and iss+ -- parameters and SHOULD support the target_link_uri parameter.++ , requestUris :: Maybe (NonEmpty URI)+ -- ^ Array of request_uri values that are pre-registered by the RP+ -- for use at the OP. Servers MAY cache the contents of the files+ -- referenced by these URIs and not retrieve them at the time they+ -- are used in a request. OPs can require that request_uri values+ -- used be pre-registered with the+ -- require_request_uri_registration discovery parameter.+ }+ deriving stock (Generic, Show)+ deriving (ToJSON, FromJSON) via GenericJSON Registration++--------------------------------------------------------------------------------+-- | The default 'Registration' value.+defaultRegistration :: Network.URI -> Registration+defaultRegistration redir =+ Registration+ { redirectUris = URI redir :| []+ , responseTypes = Nothing+ , grantTypes = Nothing+ , applicationType = Nothing+ , contacts = Nothing+ , clientName = Nothing+ , logoUri = Nothing+ , clientUri = Nothing+ , policyUri = Nothing+ , tosUri = Nothing+ , jwksUri = Nothing+ , jwks = Nothing+ , sectorIdentifierUri = Nothing+ , subjectType = Nothing+ , idTokenSignedResponseAlg = Nothing+ , idTokenEncryptedResponseAlg = Nothing+ , idTokenEncryptedResponseEnc = Nothing+ , userinfoSignedResponseAlg = Nothing+ , userinfoEncryptedResponseAlg = Nothing+ , userinfoEncryptedResponseEnc = Nothing+ , requestObjectSigningAlg = Nothing+ , requestObjectEncryptionAlg = Nothing+ , requestObjectEncryptionEnc = Nothing+ , tokenEndpointAuthMethod = ClientSecretBasic+ , tokenEndpointAuthSigningAlg = Nothing+ , defaultMaxAge = Nothing+ , requireAuthTime = Nothing+ , defaultAcrValues = Nothing+ , initiateLoginUri = Nothing+ , requestUris = Nothing+ }++--------------------------------------------------------------------------------+-- | Tag the 'ClientMetadata' and 'ClientMetadataResponse' types as+-- having no additional metadata parameters.+data BasicRegistration = BasicRegistration++instance ToJSON BasicRegistration where+ toJSON _ = Aeson.object [ ]++instance FromJSON BasicRegistration where+ parseJSON _ = pure BasicRegistration++--------------------------------------------------------------------------------+-- | Registration fields with any additional fields that are+-- necessary. If no additional fields are needed, use+-- 'BasicRegistration' to fill the type variable.+type ClientMetadata a = Registration :*: a++--------------------------------------------------------------------------------+-- | Create a complete 'ClientMetadata' record from an existing+-- 'Registration' value and any additional client metadata parameters+-- that are needed.+--+-- If you don't need to specify additional client metadata parameters+-- you can use 'BasicRegistration' as the @a@ type. In that case, the+-- type signature would be:+--+-- @+-- clientMetadata+-- :: Registration+-- -> BasicRegistration+-- -> ClientMetadata BasicRegistration+-- @+clientMetadata :: Registration -> a -> ClientMetadata a+clientMetadata r a = Join (r, a)++--------------------------------------------------------------------------------+-- | Client Registration Response.+--+-- OpenID Connect Dynamic Client Registration 1.0 §3.2.+data RegistrationResponse = RegistrationResponse+ { clientId :: Text+ -- ^ Unique Client Identifier.++ , clientSecret :: Maybe Text+ -- ^ Client Secret. This value is used by Confidential Clients to+ -- authenticate to the Token Endpoint, as described in Section+ -- 2.3.1 of OAuth 2.0, and for the derivation of symmetric+ -- encryption key values.++ , registrationAccessToken :: Maybe Text+ -- ^ Registration Access Token that can be used at the Client+ -- Configuration Endpoint to perform subsequent operations upon+ -- the Client registration.++ , registrationClientUri :: Maybe URI+ -- ^ Location of the Client Configuration Endpoint where the+ -- Registration Access Token can be used to perform subsequent+ -- operations upon the resulting Client+ -- registration. Implementations MUST either return both a Client+ -- Configuration Endpoint and a Registration Access Token or+ -- neither of them.++ , clientIdIssuedAt :: Maybe NumericDate+ -- ^ Time at which the Client Identifier was issued.++ , clientSecretExpiresAt :: Maybe NumericDate+ -- ^ If @client_secret@ is issued. Time at which the client_secret+ -- will expire or 0 if it will not expire.+ }+ deriving stock (Generic, Show)+ deriving (ToJSON, FromJSON) via GenericJSON RegistrationResponse++--------------------------------------------------------------------------------+-- | Like 'ClientMetadata' but includes the registration response.+type ClientMetadataResponse a = Registration :*: RegistrationResponse :*: a++--------------------------------------------------------------------------------+-- | Extract the registration value from a full registration response.+registrationFromResponse :: ClientMetadataResponse a -> Registration+registrationFromResponse (Join (Join (r, _), _)) = r++--------------------------------------------------------------------------------+-- | Extract the additional metadata fields from a full registration response.+additionalMetadataFromResponse :: ClientMetadataResponse a -> a+additionalMetadataFromResponse (Join (_, a)) = a++--------------------------------------------------------------------------------+-- | Extract the client details from a registration response.+clientSecretsFromResponse :: ClientMetadataResponse a -> RegistrationResponse+clientSecretsFromResponse (Join (Join (_, r), _)) = r
+ src/OpenID/Connect/Scope.hs view
@@ -0,0 +1,130 @@+{-|++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/sthenauth/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++Scope values, defined in OAuth 2.0, as used in OpenID Connect 1.0.++-}+module OpenID.Connect.Scope+ ( Scope+ , openid+ , email+ , profile+ , auth+ , hasScope+ , scopeFromWords+ , scopeQueryItem++ -- * Re-exports+ , Words(..)+ , toWords+ , fromWords+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Data.ByteString (ByteString)+import Data.Function ((&))+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.Generics (Generic)+import Network.HTTP.Types (QueryItem)+import OpenID.Connect.JSON++--------------------------------------------------------------------------------+-- | A list of @scope@ values.+--+-- To create a scope value use the 'IsString' instance or one of the+-- helper functions such as 'openid' or 'email'.+--+-- @since 0.1.0.0+newtype Scope = Scope+ { unScope :: Words+ }+ deriving stock (Generic, Show)+ deriving newtype Semigroup+ deriving (ToJSON, FromJSON) via (NonEmpty Text)++--------------------------------------------------------------------------------+instance IsString Scope where+ fromString s =+ let t = Text.pack s+ in case toWords t of+ Nothing -> Scope (Words (t :| []))+ Just w -> Scope w+++--------------------------------------------------------------------------------+-- | The @openid@ scope.+--+-- Redundant since the @openid@ scope is always added to requests.+--+-- @since 0.1.0.0+openid :: Scope+openid = "openid"++--------------------------------------------------------------------------------+-- | The @email@ scope.+--+-- @since 0.1.0.0+email :: Scope+email = "email"++--------------------------------------------------------------------------------+-- | The @profile@ scope.+--+-- @since 0.1.0.0+profile :: Scope+profile = "profile"++--------------------------------------------------------------------------------+-- | Authentication request scope.+--+-- Equivalent to @openid <> email@.+--+-- @since 0.1.0.0+auth :: Scope+auth = openid <> email++--------------------------------------------------------------------------------+-- | Test to see if the given scope includes a specific scope value.+--+-- @since 0.1.0.0+hasScope :: Scope -> Text -> Bool+hasScope s t= (t `elem`) . NonEmpty.toList . toWordList . unScope $ s++--------------------------------------------------------------------------------+-- | Convert a (non-empty) list of words into a 'Scope'.+--+-- @since 0.1.0.0+scopeFromWords :: Words -> Scope+scopeFromWords = Scope++--------------------------------------------------------------------------------+-- | Encode a 'Scope' into a query string item.+--+-- @since 0.1.0.0+scopeQueryItem :: Scope -> QueryItem+scopeQueryItem scope = ("scope", Just scopes)+ where+ scopes :: ByteString+ scopes = (scope <> openid)+ & unScope+ & fromWords+ & Text.encodeUtf8
+ src/OpenID/Connect/TokenResponse.hs view
@@ -0,0 +1,75 @@+{-|++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/sthenauth/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++-}+module OpenID.Connect.TokenResponse+ (+ -- * Token Response+ TokenResponse(..)++ -- * Re-exports+ , Words(..)+ , toWords+ , fromWords+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Data.Text (Text)+import GHC.Generics (Generic)+import OpenID.Connect.JSON++--------------------------------------------------------------------------------+-- | Authentication access token response.+--+-- RFC 6749 section 5.1. with an additional field specified in OpenID+-- Connect Core 1.0 section 3.1.3.3.+data TokenResponse a = TokenResponse+ { accessToken :: Text+ -- ^ The access token issued by the authorization server.++ , tokenType :: Text+ -- ^ The type of the token issued as described in Section 7.1.+ -- Value is case insensitive.++ , expiresIn :: Maybe Int+ -- ^ The lifetime in seconds of the access token.++ , refreshToken :: Maybe Text+ -- ^ The refresh token, which can be used to obtain new access+ -- tokens using the same authorization grant as described in+ -- Section 6.++ , scope :: Maybe Words+ -- ^ The scope of the access token as described by Section 3.3.++ , idToken :: a+ -- ^ ID Token value associated with the authenticated session.++ , atHash :: Maybe Text+ -- ^ Some flows include this hash. Access Token hash value. Its+ -- value is the base64url encoding of the left-most half of the+ -- hash of the octets of the ASCII representation of the+ -- access_token value, where the hash algorithm used is the hash+ -- algorithm used in the alg Header Parameter of the ID Token's+ -- JOSE Header.+ }+ deriving stock (Generic, Functor)++deriving via (GenericJSON (TokenResponse Text)) instance ToJSON (TokenResponse Text)+deriving via (GenericJSON (TokenResponse Text)) instance FromJSON (TokenResponse Text)+deriving via (GenericJSON (TokenResponse (Maybe Text))) instance ToJSON (TokenResponse (Maybe Text))+deriving via (GenericJSON (TokenResponse (Maybe Text))) instance FromJSON (TokenResponse (Maybe Text))
+ test/Client.hs view
@@ -0,0 +1,32 @@+{-|++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/sthenauth/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++-}+module Client+ ( test+ ) where++--------------------------------------------------------------------------------+import Test.Tasty (TestTree, testGroup)+import qualified Client.ProviderTest+import qualified Client.AuthorizationCodeTest++--------------------------------------------------------------------------------+test :: TestTree+test = testGroup "Client"+ [ Client.ProviderTest.test+ , Client.AuthorizationCodeTest.test+ ]
+ test/Client/AuthorizationCodeTest.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE QuasiQuotes #-}++{-|++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/sthenauth/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++-}+module Client.AuthorizationCodeTest+ ( test+ ) where++--------------------------------------------------------------------------------+-- Imports:+import Control.Lens ((&), (?~), (#), (.~), (^?))+import Control.Monad.Except+import Crypto.JOSE (JWK, JWKSet(..))+import Crypto.JOSE.Compact+import Crypto.JWT (ClaimsSet)+import qualified Crypto.JWT as JWT+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime)+import HttpHelper+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Types+import qualified Network.URI as Network+import qualified Network.URI.Static as Network+import OpenID.Connect.Client.Flow.AuthorizationCode+import OpenID.Connect.Provider.Key+import OpenID.Connect.TokenResponse+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit+import Web.Cookie (SetCookie, setCookieValue)++--------------------------------------------------------------------------------+test :: TestTree+test = testGroup "Authorization Code Flow"+ [ testCase "auth code" testAuthCodeRedir+ , testCase "token exchange" testTokenExchange+ ]++--------------------------------------------------------------------------------+credentials :: Credentials+credentials =+ Credentials+ { assignedClientId = "phiKei4uZeeGhaizaiph"+ , clientSecret = AssignedSecretText "oxei7ohsh0hoo7buoSui"+ , clientRedirectUri = [Network.uri|https://example.com/redir|]+ }++--------------------------------------------------------------------------------+authRequest :: AuthenticationRequest+authRequest = defaultAuthenticationRequest openid credentials++--------------------------------------------------------------------------------+redirUriAndCookie :: Discovery -> IO (Network.URI, SetCookie)+redirUriAndCookie disco =+ authenticationRedirect disco authRequest >>= \case+ Left _ -> assertFailure "did not expect failure"+ Right (RedirectTo uri cookie) -> pure (uri, cookie "foo")++--------------------------------------------------------------------------------+providerTestKeys :: IO (JWK, JWKSet)+providerTestKeys = do+ Just (JWKSet others) <- Aeson.decodeFileStrict "test/data/certs.txt"+ key <- newSigningJWK+ pure (key, JWKSet (others <> [key]))++--------------------------------------------------------------------------------+testClaims :: UTCTime -> Discovery -> Text -> ClaimsSet+testClaims now disco nonce+ = JWT.emptyClaimsSet+ & JWT.claimIss ?~ (JWT.uri # getURI (issuer disco))+ & JWT.claimAud ?~ JWT.Audience [JWT.string # assignedClientId credentials]+ & JWT.claimIat ?~ JWT.NumericDate (addUTCTime (-30) now)+ & JWT.claimExp ?~ JWT.NumericDate (addUTCTime 300 now)+ & JWT.claimSub ?~ (JWT.string # "ABC123")+ & JWT.addClaim "nonce" (Aeson.toJSON nonce)++--------------------------------------------------------------------------------+testAuthCodeRedir :: Assertion+testAuthCodeRedir = do+ Just disco <- Aeson.decodeFileStrict "test/data/discovery.txt"+ (uri, cookie) <- redirUriAndCookie disco++ Network.uriPath uri @?= "/o/oauth2/v2/auth"+ uriStart uri @?= (uriToText (getURI (authorizationEndpoint disco)) <> "?")+ assertBool "cookie value" (cookieBytes cookie > 0)++ where+ -- The URI up to and including the ?+ uriStart :: Network.URI -> Text+ uriStart u = Text.dropWhileEnd (/= '?') (uriToText u)++ cookieBytes :: SetCookie -> Int+ cookieBytes = Char8.length . setCookieValue++--------------------------------------------------------------------------------+extractQueryParam :: Network.URI -> Char8.ByteString -> IO Char8.ByteString+extractQueryParam uri name =+ case join (lookup name (parseQuery (Char8.pack (Network.uriQuery uri)))) of+ Nothing -> assertFailure ("missing query param: " <> show name)+ Just p -> pure p++--------------------------------------------------------------------------------+userReturn :: Network.URI -> SetCookie -> IO UserReturnFromRedirect+userReturn uri cookie = do+ stateParam <- extractQueryParam uri "state"+ pure UserReturnFromRedirect+ { afterRedirectSessionCookie = setCookieValue cookie+ , afterRedirectCodeParam = "aezoh0fahzu5iekeeX3u"+ , afterRedirectStateParam = stateParam+ }++--------------------------------------------------------------------------------+testTokenExchange :: Assertion+testTokenExchange = do+ Just disco <- Aeson.decodeFileStrict "test/data/discovery.txt"+ (uri, cookie) <- redirUriAndCookie disco+ (key, keyset) <- providerTestKeys+ now <- getCurrentTime+ browser <- userReturn uri cookie+ nonce <- extractQueryParam uri "nonce"++ let makeRequest = makeRequest_ now disco key+ claims = testClaims now disco (Text.decodeUtf8 nonce)++ -- Happy path:+ makeRequest claims keyset browser+ >>= validateRequest+ >>= assertResponseSuccess++ -- Wrong cookie:+ makeRequest claims keyset+ (browser { afterRedirectSessionCookie = "foo"+ }) >>= assertNoRequestMade+ >>= assertResponseFailed++ -- Wrong state field:+ makeRequest claims keyset+ (browser { afterRedirectStateParam = "foo"+ }) >>= assertNoRequestMade+ >>= assertResponseFailed++ -- Multiple audience entries without an AZP:+ let dupAud = JWT.Audience+ [ JWT.string # assignedClientId credentials+ , JWT.string # assignedClientId credentials+ ]+ makeRequest (claims & JWT.claimAud ?~ dupAud)+ keyset browser >>= validateRequest+ >>= assertResponseFailed++ -- Multiple audience entries with an AZP:+ let withAzp = JWT.addClaim "azp" (Aeson.String (assignedClientId credentials))+ makeRequest (claims & JWT.claimAud ?~ dupAud & withAzp)+ keyset browser >>= validateRequest+ >>= assertResponseSuccess++ -- Wrong nonce:+ let wrongNonce = "foo" :: Text+ makeRequest (claims & JWT.addClaim "nonce" (Aeson.toJSON wrongNonce))+ keyset browser >>= validateRequest+ >>= assertResponseFailed++ -- Wrong audience:+ makeRequest (claims & JWT.claimAud ?~ JWT.Audience [JWT.string # "foo"])+ keyset browser >>= validateRequest+ >>= assertResponseFailed++ -- Wrong issuer:+ let wrongIssuer = "foo" :: Text+ makeRequest (claims & JWT.claimIss .~ wrongIssuer ^? JWT.stringOrUri)+ keyset browser >>= validateRequest+ >>= assertResponseFailed++ -- Expired claims:+ makeRequest (claims & JWT.claimExp ?~ JWT.NumericDate (addUTCTime (-300) now))+ keyset browser >>= validateRequest+ >>= assertResponseFailed++ -- Wrong Keys:+ Just wrongKeys <- Aeson.decodeFileStrict "test/data/certs.txt"+ makeRequest claims wrongKeys browser+ >>= validateRequest+ >>= assertResponseFailed++ where+ makeRequest_+ :: UTCTime+ -> Discovery+ -> JWK+ -> ClaimsSet+ -> JWKSet+ -> UserReturnFromRedirect+ -> IO (Either FlowError (TokenResponse ClaimsSet), HTTP.Request)+ makeRequest_ time disco key claims keyset browser = do+ claims' <- runExceptT+ (do algo <- JWT.bestJWSAlg key+ JWT.signClaims key (JWT.newJWSHeader ((), algo)) claims)+ >>= \case+ Left (e :: JWT.JWTError) -> fail (show e)+ Right a -> pure a++ let token = TokenResponse+ { accessToken = "Iegoe0sheeSeo3veesoo"+ , tokenType = "Bearer"+ , expiresIn = Just 3600+ , refreshToken = Nothing+ , scope = Nothing+ , idToken = Text.decodeUtf8 (LChar8.toStrict (encodeCompact claims'))+ , atHash = Nothing+ }++ let https = fakeHttpsFromByteString (Aeson.encode token) & mkHTTPS+ provider = Provider disco keyset+ runHTTPS (authenticationSuccess https time provider credentials browser)++ validateRequest :: (a, HTTP.Request) -> IO a+ validateRequest (x, req) = do+ HTTP.method req @?= "POST"+ Network.uriScheme (HTTP.getUri req) @?= "https:"+ assertBool "should be a secure connection" (HTTP.secure req)+ pure x++ assertNoRequestMade :: (a, HTTP.Request) -> IO a+ assertNoRequestMade (x, req) = do+ HTTP.method req @?= "NONE" -- See HttpHelper.hs+ pure x++ assertResponseSuccess :: Either FlowError a -> Assertion+ assertResponseSuccess = \case+ Left e -> assertFailure ("didn't expect Failed: " <> show e)+ Right _ -> pure ()++ assertResponseFailed :: Either FlowError a -> Assertion+ assertResponseFailed = \case+ Right _ -> assertFailure "didn't expect Success"+ Left _ -> pure ()
+ test/Client/ProviderTest.hs view
@@ -0,0 +1,63 @@+{-|++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/sthenauth/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++-}+module Client.ProviderTest+ ( test+ ) where++--------------------------------------------------------------------------------+import Crypto.JOSE.JWK (JWKSet(..))+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy.Char8 as LChar8+import HttpHelper+import qualified Network.HTTP.Client.Internal as HTTP+import qualified Network.HTTP.Types.Header as HTTP+import OpenID.Connect.Client.Provider+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit++--------------------------------------------------------------------------------+test :: TestTree+test = testGroup "Provider Info"+ [ testCase "JWK Set" testKeyParsing+ ]++--------------------------------------------------------------------------------+testKeyParsing :: Assertion+testKeyParsing = do+ let fake = (defaultFakeHTTPS "test/data/certs.txt")+ { fakeHeaders =+ [ (HTTP.hDate, "Thu, 20 Feb 2020 22:26:11 GMT")+ , (HTTP.hExpires, "Fri, 21 Feb 2020 03:59:07 GMT")+ , (HTTP.hCacheControl, "public, max-age=19976, must-revalidate, no-transform")+ ]+ }++ https = mkHTTPS fake++ Just disco <- Aeson.decode <$> LChar8.readFile "test/data/discovery.txt"+ (res, req) <- runHTTPS (keysFromDiscovery https disco)++ HTTP.path req @?= "/oauth2/v3/certs"+ HTTP.method req @?= "GET"+ HTTP.secure req @?= True++ case res of+ Left e -> fail (show e)+ Right (JWKSet jwks, cache) -> do+ length jwks @?= 2+ fmap show cache @?= Just "2020-02-21 03:59:07 UTC"
+ test/DiscoveryTest.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE QuasiQuotes #-}++{-|++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/sthenauth/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++-}+module DiscoveryTest+ ( test+ ) where++--------------------------------------------------------------------------------+import HttpHelper+import qualified Network.HTTP.Client.Internal as HTTP+import Network.URI (parseURI)+import qualified Network.URI.Static as Network+import OpenID.Connect.Client.Provider+import OpenID.Connect.Scope+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit++--------------------------------------------------------------------------------+test :: TestTree+test = testGroup "Discovery"+ [ testCase "discovery" testDiscoveryParsing+ ]++--------------------------------------------------------------------------------+testDiscoveryParsing :: Assertion+testDiscoveryParsing = do+ let fake = defaultFakeHTTPS "test/data/discovery.txt"+ https = mkHTTPS fake+ url <- maybe (fail "WTF?") pure (parseURI "https://accounts.google.com/")+ (res, req) <- runHTTPS (discovery https url)++ HTTP.path req @?= "/.well-known/openid-configuration"+ HTTP.method req @?= "GET"+ HTTP.secure req @?= True++ case res of+ Left e -> fail (show e)+ Right (Discovery{..}, cache) -> do+ issuer @?= URI [Network.uri|https://accounts.google.com|]+ authorizationEndpoint @?= URI [Network.uri|https://accounts.google.com/o/oauth2/v2/auth|]+ jwksUri @?= URI [Network.uri|https://www.googleapis.com/oauth2/v3/certs|]++ fmap (`hasScope` "openid") scopesSupported @?= Just True+ fmap (`hasScope` "email") scopesSupported @?= Just True+ fmap (`hasScope` "profile") scopesSupported @?= Just True+ fmap show cache @?= Just "2020-02-20 20:40:21 UTC"
+ test/HttpHelper.hs view
@@ -0,0 +1,96 @@+{-|++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/sthenauth/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++-}+module HttpHelper+ ( FakeHTTPS(..)+ , defaultFakeHTTPS+ , fakeHttpsFromByteString+ , httpNoOp+ , mkHTTPS+ , runHTTPS+ ) where++--------------------------------------------------------------------------------+import Control.Monad.State.Strict+import qualified Data.ByteString.Lazy.Char8 as LChar8+import qualified Network.HTTP.Client.Internal as HTTP+import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Types.Header as HTTP++--------------------------------------------------------------------------------+data FakeHTTPS = FakeHTTPS+ { fakeStatus :: HTTP.Status+ , fakeVersion :: HTTP.HttpVersion+ , fakeHeaders :: HTTP.ResponseHeaders+ , fakeData :: IO LChar8.ByteString+ }++--------------------------------------------------------------------------------+defaultFakeHTTPS :: FilePath -> FakeHTTPS+defaultFakeHTTPS = defaultFakeHTTPS' . LChar8.readFile++--------------------------------------------------------------------------------+fakeHttpsFromByteString :: LChar8.ByteString -> FakeHTTPS+fakeHttpsFromByteString = defaultFakeHTTPS' . pure++--------------------------------------------------------------------------------+defaultFakeHTTPS' :: IO LChar8.ByteString -> FakeHTTPS+defaultFakeHTTPS' rdata =+ FakeHTTPS+ { fakeStatus = HTTP.status200+ , fakeVersion = HTTP.http20+ , fakeHeaders = headers+ , fakeData = rdata+ }+ where+ headers :: HTTP.ResponseHeaders+ headers =+ [ (HTTP.hDate, "Thu, 20 Feb 2020 19:40:21 GMT")+ , (HTTP.hExpires, "Thu, 20 Feb 2020 21:40:21 GMT")+ , (HTTP.hCacheControl, "public, max-age=3600")+ , (HTTP.hContentType, "application/json")+ ]++--------------------------------------------------------------------------------+httpNoOp+ :: MonadFail m+ => HTTP.Request+ -> m (HTTP.Response LChar8.ByteString)+httpNoOp _ = fail "httpNoOp"++--------------------------------------------------------------------------------+mkHTTPS+ :: MonadIO m+ => FakeHTTPS+ -> HTTP.Request+ -> StateT HTTP.Request m (HTTP.Response LChar8.ByteString)+mkHTTPS FakeHTTPS{..} request = do+ put request++ HTTP.Response+ <$> pure fakeStatus+ <*> pure fakeVersion+ <*> pure fakeHeaders+ <*> liftIO fakeData+ <*> pure mempty+ <*> pure (HTTP.ResponseClose (pure ()))++--------------------------------------------------------------------------------+runHTTPS+ :: StateT HTTP.Request m a+ -> m (a, HTTP.Request)+runHTTPS = (`runStateT` (HTTP.defaultRequest { HTTP.method = "NONE" }))
+ test/Main.hs view
@@ -0,0 +1,30 @@+{-|++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/sthenauth/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++-}+module Main (main) where++--------------------------------------------------------------------------------+import Test.Tasty+import qualified Client+import qualified DiscoveryTest++--------------------------------------------------------------------------------+main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ Client.test+ , DiscoveryTest.test+ ]