diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,7 @@ +Revision History for `openid-connect` +===================================== + +Version 0.1.0.0 (March 25, 2020) +-------------------------------- + +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2020 Peter J. Jones +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,64 @@ +[![sthenauth](https://circleci.com/gh/sthenauth/openid-connect.svg?style=shield)](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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Auth.hs b/example/Auth.hs new file mode 100644 --- /dev/null +++ b/example/Auth.hs @@ -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 + } diff --git a/example/Discover.hs b/example/Discover.hs new file mode 100644 --- /dev/null +++ b/example/Discover.hs @@ -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 + } diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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) diff --git a/example/Options.hs b/example/Options.hs new file mode 100644 --- /dev/null +++ b/example/Options.hs @@ -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 diff --git a/example/Util.hs b/example/Util.hs new file mode 100644 --- /dev/null +++ b/example/Util.hs @@ -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 "<>" + + res <- httpLbs request mgr + hPrint stderr res + hFlush stderr + pure res + +-------------------------------------------------------------------------------- +https :: Manager -> HTTPS IO +https = httpsDebug diff --git a/example/certification.sh b/example/certification.sh new file mode 100644 --- /dev/null +++ b/example/certification.sh @@ -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: diff --git a/example/make-tls-certs.sh b/example/make-tls-certs.sh new file mode 100644 --- /dev/null +++ b/example/make-tls-certs.sh @@ -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" diff --git a/openid-connect.cabal b/openid-connect.cabal new file mode 100644 --- /dev/null +++ b/openid-connect.cabal @@ -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 +maintainer: Peter Jones +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 diff --git a/src/OpenID/Connect/Authentication.hs b/src/OpenID/Connect/Authentication.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Authentication.hs @@ -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 diff --git a/src/OpenID/Connect/Client/Authentication.hs b/src/OpenID/Connect/Client/Authentication.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Client/Authentication.hs @@ -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 diff --git a/src/OpenID/Connect/Client/DynamicRegistration.hs b/src/OpenID/Connect/Client/DynamicRegistration.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Client/DynamicRegistration.hs @@ -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) diff --git a/src/OpenID/Connect/Client/Flow/AuthorizationCode.hs b/src/OpenID/Connect/Client/Flow/AuthorizationCode.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Client/Flow/AuthorizationCode.hs @@ -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 diff --git a/src/OpenID/Connect/Client/HTTP.hs b/src/OpenID/Connect/Client/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Client/HTTP.hs @@ -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 diff --git a/src/OpenID/Connect/Client/Provider.hs b/src/OpenID/Connect/Client/Provider.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Client/Provider.hs @@ -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) diff --git a/src/OpenID/Connect/Client/TokenResponse.hs b/src/OpenID/Connect/Client/TokenResponse.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Client/TokenResponse.hs @@ -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) diff --git a/src/OpenID/Connect/Discovery.hs b/src/OpenID/Connect/Discovery.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Discovery.hs @@ -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: +-- +-- +-- @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 diff --git a/src/OpenID/Connect/JSON.hs b/src/OpenID/Connect/JSON.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/JSON.hs @@ -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 diff --git a/src/OpenID/Connect/Provider/Key.hs b/src/OpenID/Connect/Provider/Key.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Provider/Key.hs @@ -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 diff --git a/src/OpenID/Connect/Registration.hs b/src/OpenID/Connect/Registration.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Registration.hs @@ -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 diff --git a/src/OpenID/Connect/Scope.hs b/src/OpenID/Connect/Scope.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/Scope.hs @@ -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 diff --git a/src/OpenID/Connect/TokenResponse.hs b/src/OpenID/Connect/TokenResponse.hs new file mode 100644 --- /dev/null +++ b/src/OpenID/Connect/TokenResponse.hs @@ -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)) diff --git a/test/Client.hs b/test/Client.hs new file mode 100644 --- /dev/null +++ b/test/Client.hs @@ -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 + ] diff --git a/test/Client/AuthorizationCodeTest.hs b/test/Client/AuthorizationCodeTest.hs new file mode 100644 --- /dev/null +++ b/test/Client/AuthorizationCodeTest.hs @@ -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 () diff --git a/test/Client/ProviderTest.hs b/test/Client/ProviderTest.hs new file mode 100644 --- /dev/null +++ b/test/Client/ProviderTest.hs @@ -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" diff --git a/test/DiscoveryTest.hs b/test/DiscoveryTest.hs new file mode 100644 --- /dev/null +++ b/test/DiscoveryTest.hs @@ -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" diff --git a/test/HttpHelper.hs b/test/HttpHelper.hs new file mode 100644 --- /dev/null +++ b/test/HttpHelper.hs @@ -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" })) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ]