From 0d74f8c1ca9c1e9bf9a04b85f598ba7a175d1d86 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Tue, 21 Sep 2021 19:49:24 +0200 Subject: OIDC configuration: use GOOPS and document it --- src/scm/webid-oidc/access-token.scm | 1 - src/scm/webid-oidc/client.scm | 1 - src/scm/webid-oidc/client/accounts.scm | 34 ++-- src/scm/webid-oidc/client/application.scm | 1 - src/scm/webid-oidc/client/client.scm | 1 - src/scm/webid-oidc/client/gui.scm | 1 - src/scm/webid-oidc/identity-provider.scm | 11 +- src/scm/webid-oidc/jws.scm | 19 +- src/scm/webid-oidc/oidc-configuration.scm | 301 +++++++++++++++--------------- src/scm/webid-oidc/oidc-id-token.scm | 1 - src/scm/webid-oidc/parameters.scm | 7 +- src/scm/webid-oidc/resource-server.scm | 1 - 12 files changed, 184 insertions(+), 195 deletions(-) (limited to 'src/scm/webid-oidc') diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm index 7c23126..0960069 100644 --- a/src/scm/webid-oidc/access-token.scm +++ b/src/scm/webid-oidc/access-token.scm @@ -18,7 +18,6 @@ #:use-module (webid-oidc jws) #:use-module (webid-oidc errors) #:use-module (webid-oidc jwk) - #:use-module (webid-oidc oidc-configuration) #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index 006c86a..2c16fb1 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -17,7 +17,6 @@ (define-module (webid-oidc client) #:use-module (webid-oidc errors) #:use-module (webid-oidc provider-confirmation) - #:use-module (webid-oidc oidc-configuration) #:use-module (webid-oidc oidc-id-token) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc jwk) diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm index 3591b52..7e14000 100644 --- a/src/scm/webid-oidc/client/accounts.scm +++ b/src/scm/webid-oidc/client/accounts.scm @@ -31,7 +31,7 @@ #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc oidc-id-token) #:prefix id:) - #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:) + #:use-module (webid-oidc oidc-configuration) #:use-module ((webid-oidc jwk) #:prefix jwk:) #:use-module (webid-oidc dpop-proof) #:use-module ((webid-oidc client client) #:prefix client:) @@ -41,6 +41,10 @@ #:use-module (rnrs bytevectors) #:use-module (oop goops) #:declarative? #t + #:re-export + ( + (p:anonymous-http-request . anonymous-http-request) + ) #:export ( @@ -58,7 +62,6 @@ authorization-process authorization-state - anonymous-http-request &authorization-code-required make-authorization-code-required @@ -129,15 +132,12 @@ (define authorization-state (make-parameter #f)) -(define anonymous-http-request - (make-parameter http-request)) - (define (http-request->http-get http-request) (lambda* (uri . all-args) (apply http-request uri #:method 'GET all-args))) (define (http-get-implementation) - (http-request->http-get (anonymous-http-request))) + (http-request->http-get (p:anonymous-http-request))) (define-class () (subject #:init-keyword #:subject #:getter subject) @@ -157,13 +157,16 @@ (define-method (->sexp (account )) `(begin - (use-modules (oop goops) (webid-oidc client accounts) (webid-oidc jwk)) + (use-modules (oop goops) (webid-oidc client accounts) (webid-oidc jwk) (webid-oidc jws) (webid-oidc oidc-id-token)) (make #:subject ,(uri->string (subject account)) #:issuer ,(uri->string (issuer account)) ,@(let ((id-token (id-token account))) (if id-token - `(#:id-token (quote ,id-token)) + (receive (header payload) (token->jwk id-token) + `(#:id-token (make + #:jws-header (quote ,header) + #:jws-payload (quote ,payload)))) '())) ,@(let ((access-token (access-token account))) (if access-token @@ -217,14 +220,11 @@ (let ((client (client:client))) (receive (authorization-endpoint token-endpoint) (let ((configuration - (cfg:get-oidc-configuration - (uri-host issuer) - #:userinfo (uri-userinfo issuer) - #:port (uri-port issuer) - #:http-get (http-get-implementation)))) + (make + #:server issuer))) (values - (cfg:oidc-configuration-authorization-endpoint configuration) - (cfg:oidc-configuration-token-endpoint configuration))) + (authorization-endpoint configuration) + (token-endpoint configuration))) (receive (grant-type grant) (if refresh-token (values "refresh_token" refresh-token) @@ -261,7 +261,7 @@ #:htm 'POST #:htu token-endpoint))) (receive (response response-body) - ((anonymous-http-request) token-endpoint + ((p:anonymous-http-request) token-endpoint #:method 'POST #:body (string-join @@ -372,7 +372,7 @@ (lambda () (set! id-token (decode id-token - #:http-request (anonymous-http-request))))) + #:http-request (p:anonymous-http-request))))) ;; We are not interested in the ID token ;; signature anymore, because it won’t be ;; transmitted to other parties and we know that diff --git a/src/scm/webid-oidc/client/application.scm b/src/scm/webid-oidc/client/application.scm index 74fcefe..5839195 100644 --- a/src/scm/webid-oidc/client/application.scm +++ b/src/scm/webid-oidc/client/application.scm @@ -31,7 +31,6 @@ #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc oidc-id-token) #:prefix id:) - #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:) #:use-module ((webid-oidc jwk) #:prefix jwk:) #:use-module ((webid-oidc dpop-proof) #:prefix dpop:) #:use-module ((webid-oidc client client) #:prefix client:) diff --git a/src/scm/webid-oidc/client/client.scm b/src/scm/webid-oidc/client/client.scm index 5da701b..01f8da1 100644 --- a/src/scm/webid-oidc/client/client.scm +++ b/src/scm/webid-oidc/client/client.scm @@ -17,7 +17,6 @@ (define-module (webid-oidc client client) #:use-module (webid-oidc errors) #:use-module (webid-oidc provider-confirmation) - #:use-module (webid-oidc oidc-configuration) #:use-module (webid-oidc oidc-id-token) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc web-i18n) diff --git a/src/scm/webid-oidc/client/gui.scm b/src/scm/webid-oidc/client/gui.scm index 3bfaf6a..c0d0767 100644 --- a/src/scm/webid-oidc/client/gui.scm +++ b/src/scm/webid-oidc/client/gui.scm @@ -31,7 +31,6 @@ #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc oidc-id-token) #:prefix id:) - #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:) #:use-module ((webid-oidc jwk) #:prefix jwk:) #:use-module ((webid-oidc dpop-proof) #:prefix dpop:) #:use-module ((webid-oidc client client) #:prefix client:) diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm index 7973917..46de33c 100644 --- a/src/scm/webid-oidc/identity-provider.scm +++ b/src/scm/webid-oidc/identity-provider.scm @@ -42,6 +42,7 @@ #:use-module (srfi srfi-19) #:use-module (rnrs bytevectors) #:use-module (oop goops) + #:duplicates (merge-generics) #:declarative? #t #:export ( @@ -86,10 +87,10 @@ (token-endpoint (make-token-endpoint token-endpoint-uri issuer key 3600)) (openid-configuration - `((jwks_uri . ,(uri->string jwks-uri)) - (authorization_endpoint . ,(uri->string authorization-endpoint-uri)) - (token_endpoint . ,(uri->string token-endpoint-uri)) - (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc"))) + (make + #:jwks-uri jwks-uri + #:authorization-endpoint authorization-endpoint-uri + #:token-endpoint token-endpoint-uri)) (openid-configuration-uri (build-uri 'https #:host (uri-host issuer) @@ -103,7 +104,7 @@ (exp-sec (+ current-sec 3600)) (exp (time-utc->date (make-time time-utc 0 exp-sec)))) - (serve-oidc-configuration exp openid-configuration))) + (serve openid-configuration exp))) ((same-uri? uri jwks-uri) (let* ((current-sec (time-second (date->time-utc current-time))) (exp-sec (+ current-sec 3600)) diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm index 22dabdd..bfb941f 100644 --- a/src/scm/webid-oidc/jws.scm +++ b/src/scm/webid-oidc/jws.scm @@ -472,7 +472,7 @@ (define-method (lookup-keys (token ) args) (let-keywords args #f - ((http-request http-request)) + ((http-request (p:anonymous-http-request))) (let ((iss (iss token))) (let ((cfg (with-exception-handler @@ -488,13 +488,9 @@ (make-exception-with-message final-message) error)))) (lambda () - (get-oidc-configuration - (uri-host iss) - #:userinfo (uri-userinfo iss) - #:port (uri-port iss) - #:http-get - (lambda* (uri . args) - (apply http-request uri #:method 'GET args))))))) + (make + #:server iss + #:http-request http-request))))) (with-exception-handler (lambda (error) (raise-exception @@ -509,11 +505,8 @@ (append (keys (next-method)) (keys - (oidc-configuration-jwks - cfg - #:http-get - (lambda* (uri . args) - (apply http-request uri #:method 'GET args))))))))))) + (parameterize ((p:anonymous-http-request http-request)) + (jwks cfg)))))))))) (define verify (make diff --git a/src/scm/webid-oidc/oidc-configuration.scm b/src/scm/webid-oidc/oidc-configuration.scm index 2233d95..0a776d1 100644 --- a/src/scm/webid-oidc/oidc-configuration.scm +++ b/src/scm/webid-oidc/oidc-configuration.scm @@ -19,6 +19,7 @@ #:use-module (webid-oidc errors) #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (web client) #:use-module (web response) @@ -28,6 +29,7 @@ #:use-module (ice-9 optargs) #:use-module (ice-9 exceptions) #:use-module (ice-9 match) + #:use-module (oop goops) #:declarative? #t #:export ( @@ -35,14 +37,14 @@ make-invalid-oidc-configuratioon invalid-oidc-configuration? - the-oidc-configuration - oidc-configuration? - oidc-configuration-jwks-uri - oidc-configuration-authorization-endpoint - oidc-configuration-token-endpoint - oidc-configuration-jwks - serve-oidc-configuration - get-oidc-configuration + + jwks-uri + authorization-endpoint + token-endpoint + jwks + serve + + ->json-data )) (define-exception-type @@ -51,152 +53,149 @@ make-invalid-oidc-configuration invalid-oidc-configuration?) -(define (the-oidc-configuration x) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the OIDC configuration is invalid: ~a") - (exception-message error)) - (format #f (G_ "the OIDC configuration is invalid"))))) - (raise-exception - (make-exception - (make-invalid-oidc-configuration) - (make-exception-with-message final-message) - error)))) - (lambda () - (let examine ((data x) - (jwks-uri #f) - (token-endpoint #f) - (authorization-endpoint #f) - (solid-oidc-supported #f) - (other-fields '())) - (match data - (() - (unless (and jwks-uri token-endpoint authorization-endpoint solid-oidc-supported) - (fail (format #f (G_ "the OIDC configuration does not have: ~s") - `(,@(if jwks-uri '() '("jwks_uri")) - ,@(if token-endpoint '() '("token_endpoint")) - ,@(if authorization-endpoint '() '("authorization_endpoint")) - ,@(if solid-oidc-supported '() '("solid_oidc_supported")))))) - `((jwks_uri . ,(uri->string jwks-uri)) - (token_endpoint . ,(uri->string token-endpoint)) - (authorization_endpoint . ,(uri->string authorization-endpoint)) - (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc") - ,@(reverse other-fields))) - ((('jwks_uri . (? string->uri (? string? given-jwks-uri))) data ...) - (examine data (or jwks-uri (string->uri given-jwks-uri)) - token-endpoint authorization-endpoint - solid-oidc-supported other-fields)) - ((('jwks_uri . invalid) data ...) - (fail (format #f (G_ "invalid JWKS URI: ~s") - invalid))) - ((('token_endpoint . (? string->uri (? string? given-token-endpoint))) data ...) - (examine data jwks-uri - (or token-endpoint (string->uri given-token-endpoint)) - authorization-endpoint solid-oidc-supported other-fields)) - ((('token_endpoint . invalid) data ...) - (fail (format #f (G_ "invalid token endpoint: ~s") - invalid))) - ((('authorization_endpoint - . (? string->uri (? string? given-authorization-endpoint))) - data ...) - (examine data jwks-uri token-endpoint - (or authorization-endpoint (string->uri given-authorization-endpoint)) - solid-oidc-supported other-fields)) - ((('authorization_endpoint . invalid) data ...) - (fail (format #f (G_ "invalid authorization endpoint: ~s") - invalid))) - ((('solid_oidc_supported . "https://solidproject.org/TR/solid-oidc") - data ...) - (examine data jwks-uri token-endpoint authorization-endpoint - (or solid-oidc-supported #t) - other-fields)) - ((('solid_oidc_supported . incorrect) data ...) - (fail (format #f (G_ "\"solid_oidc_supported\" should be set to ~s, not ~s") - "https://solidproject.org/TR/solid-oidc" - incorrect))) - ((((? symbol? key) . value) data ...) - (examine data jwks-uri token-endpoint authorization-endpoint - solid-oidc-supported - `((,key . ,value) ,@other-fields))) - (else - (fail (format #f (G_ "invalid JSON object"))))))))) - -(define (oidc-configuration? obj) - (false-if-exception - (the-oidc-configuration obj))) - -(define (uri-field what) - (lambda (x) - (let ((str (assq-ref (the-oidc-configuration x) what))) - (string->uri str)))) - -(define oidc-configuration-jwks-uri - (uri-field 'jwks_uri)) - -(define oidc-configuration-authorization-endpoint - (uri-field 'authorization_endpoint)) +(define-class () + (jwks-uri #:init-keyword #:jwks-uri #:accessor jwks-uri) + (authorization-endpoint #:init-keyword #:authorization-endpoint #:accessor authorization-endpoint) + (token-endpoint #:init-keyword #:token-endpoint #:accessor token-endpoint)) -(define oidc-configuration-token-endpoint - (uri-field 'token_endpoint)) +(define-method (initialize (cfg ) initargs) + (next-method) + (let-keywords + initargs #t + ((jwks-uri #f) + (authorization-endpoint #f) + (token-endpoint #f) + (solid-oidc-supported "https://solidproject.org/TR/solid-oidc") + (json-data #f) + (server #f) + (http-request (p:anonymous-http-request))) + (let do-initialize ((jwks-uri jwks-uri) + (authorization-endpoint authorization-endpoint) + (token-endpoint token-endpoint) + (solid-oidc-supported solid-oidc-supported) + (json-data json-data) + (server server)) + (cond + ((string? jwks-uri) + (do-initialize (string->uri jwks-uri) + authorization-endpoint + token-endpoint + solid-oidc-supported + json-data + server)) + ((string? authorization-endpoint) + (do-initialize jwks-uri + (string->uri authorization-endpoint) + token-endpoint + solid-oidc-supported + json-data + server)) + ((string? token-endpoint) + (do-initialize jwks-uri + authorization-endpoint + (string->uri token-endpoint) + solid-oidc-supported + json-data + server)) + ((string? server) + ;; Either it is an URI, or it is a host name + (do-initialize jwks-uri + authorization-endpoint + token-endpoint + solid-oidc-supported + json-data + (or (false-if-exception (string->uri server)) + (false-if-exception + (build-uri 'https #:host server))))) + (json-data + (do-initialize (assq-ref json-data 'jwks_uri) + (assq-ref json-data 'authorization_endpoint) + (assq-ref json-data 'token_endpoint) + (assq-ref json-data 'solid_oidc_supported) + #f #f)) + ((and jwks-uri authorization-endpoint token-endpoint solid-oidc-supported) + (begin + (unless (uri? jwks-uri) + (scm-error 'wrong-type-arg "make" + (G_ "#:jwks-uri should be an URI") + '() + (list jwks-uri))) + (unless (uri? token-endpoint) + (scm-error 'wrong-type-arg "make" + (G_ "#:token-endpoint should be an URI") + '() + (list token-endpoint))) + (unless (uri? authorization-endpoint) + (scm-error 'wrong-type-arg "make" + (G_ "#:authorization-endpoint should be an URI") + '() + (list authorization-endpoint))) + (unless (equal? solid-oidc-supported "https://solidproject.org/TR/solid-oidc") + (scm-error 'wrong-type-arg "make" + (G_ "#:solid-oidc-supported should be exactly 'https://solidproject.org/TR/solid-oidc'") + '() + (list solid-oidc-supported))) + (slot-set! cfg 'jwks-uri jwks-uri) + (slot-set! cfg 'token-endpoint token-endpoint) + (slot-set! cfg 'authorization-endpoint authorization-endpoint))) + (server + (unless (uri? server) + (scm-error 'wrong-type-arg "make" + (G_ "#:server should be an URI") + '() + (list server))) + (let ((discovery-uri + (build-uri (uri-scheme server) + #:userinfo (uri-userinfo server) + #:host (uri-host server) + #:port (uri-port server) + #:path "/.well-known/openid-configuration"))) + (receive (response response-body) (http-request discovery-uri) + (with-exception-handler + (lambda (error) + (raise-exception + (make-exception + (make-invalid-oidc-configuration) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "cannot fetch the OIDC configuration: ~a") + (exception-message error)) + (format #f (G_ "cannot fetch the OIDC configuration")))) + error))) + (lambda () + (unless (eqv? (response-code response) 200) + (fail (format #f (G_ "the server responded with ~s ~s") + (response-code response) + (response-reason-phrase response)))) + (let ((content-type (response-content-type response))) + (unless content-type + (fail (format #f (G_ "there is no content-type")))) + (unless (and (eq? (car content-type) 'application/json) + (or (equal? (assoc-ref (cdr content-type) 'charset) + "utf-8") + (not (assoc-ref (cdr content-type) 'charset)))) + (fail (format #f (G_ "unexpected content-type: ~s") + content-type))) + (unless (string? response-body) + (set! response-body (utf8->string response-body))) + (do-initialize #f #f #f #f (stubs:json-string->scm response-body) #f))))))) + (else + (raise-exception + (make-exception + (make-invalid-oidc-configuratin) + (make-exception-with-message + (G_ "when making an OIDC configuration, either its required #:jwks-uri, #:authorization-endpoint and #:token-endpoint fields or #:server (and optionally #:http-request) or #:json-data should be passed"))))))))) -(define* (oidc-configuration-jwks cfg #:key (http-get http-get)) - (let ((http-request-for-get-jwks - (lambda* (uri #:key (method 'GET)) - (http-get uri)))) - (get-jwks (oidc-configuration-jwks-uri cfg) - #:http-request http-request-for-get-jwks))) +(define-method (->json-data (cfg )) + `((jwks_uri . ,(uri->string (jwks-uri cfg))) + (authorization_endpoint . ,(uri->string (authorization-endpoint cfg))) + (token_endpoint . ,(uri->string (token-endpoint cfg))) + (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc"))) -(define (serve-oidc-configuration expiration-date cfg) +(define-method (serve (cfg ) expiration-date) (values (build-response #:headers `((content-type . (application/json)) (expires . ,expiration-date))) - (stubs:scm->json-string cfg))) + (stubs:scm->json-string (->json-data cfg)))) -(define* (get-oidc-configuration host - #:key - (userinfo #f) - (port #f) - (http-get http-get)) - (when (and (string? host) - (false-if-exception - (string->uri host))) - ;; host is something like "https://example.com" - (set! host (string->uri host))) - (when (uri? host) - (set! host (uri-host host))) - (let ((uri (build-uri 'https - #:userinfo userinfo - #:host host - #:port port - #:path "/.well-known/openid-configuration"))) - (receive (response response-body) (http-get uri) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "cannot fetch the OIDC configuration: ~a") - (exception-message error)) - (format #f (G_ "cannot fetch the OIDC configuration"))))) - (raise-exception - (make-exception - (make-invalid-oidc-configuration) - (make-exception-with-message final-message) - error)))) - (lambda () - (unless (eqv? (response-code response) 200) - (fail (format #f (G_ "the server responded with ~s ~s") - (response-code response) - (response-reason-phrase response)))) - (let ((content-type (response-content-type response))) - (unless content-type - (fail (format #f (G_ "there is no content-type")))) - (unless (and (eq? (car content-type) 'application/json) - (or (equal? (assoc-ref (cdr content-type) 'charset) - "utf-8") - (not (assoc-ref (cdr content-type) 'charset)))) - (fail (format #f (G_ "unexpected content-type: ~s") - content-type))) - (unless (string? response-body) - (set! response-body (utf8->string response-body))) - (the-oidc-configuration (stubs:json-string->scm response-body)))))))) +(define-method (jwks (cfg )) + (get-jwks (jwks-uri cfg) #:http-request (p:anonymous-http-request))) diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm index 1d96a47..a33351b 100644 --- a/src/scm/webid-oidc/oidc-id-token.scm +++ b/src/scm/webid-oidc/oidc-id-token.scm @@ -15,7 +15,6 @@ ;; along with this program. If not, see . (define-module (webid-oidc oidc-id-token) - #:use-module (webid-oidc oidc-configuration) #:use-module (webid-oidc errors) #:use-module (webid-oidc jws) #:use-module (webid-oidc jwk) diff --git a/src/scm/webid-oidc/parameters.scm b/src/scm/webid-oidc/parameters.scm index 603a2cd..7d10798 100644 --- a/src/scm/webid-oidc/parameters.scm +++ b/src/scm/webid-oidc/parameters.scm @@ -16,8 +16,8 @@ (define-module (webid-oidc parameters) #:use-module (srfi srfi-19) - #:use-module (webid-oidc jti) - #:export (data-home cache-home current-date) + #:use-module (web client) + #:export (data-home cache-home current-date anonymous-http-request) #:declarative? #t) (define data-home @@ -49,3 +49,6 @@ (when (time? date) (set! date (time-utc->date date))) date))))) + +(define anonymous-http-request + (make-parameter http-request)) diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index 99291b0..bae9db9 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -16,7 +16,6 @@ (define-module (webid-oidc resource-server) #:use-module (webid-oidc errors) - #:use-module (webid-oidc oidc-configuration) #:use-module (webid-oidc provider-confirmation) #:use-module (webid-oidc jwk) #:use-module (webid-oidc dpop-proof) -- cgit v1.2.3