From 5821fa66bc1f92e466020bfa4c14989199a02146 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Sun, 29 Nov 2020 19:21:28 +0100 Subject: Get an openid configuration on the web --- src/scm/webid-oidc/Makefile.am | 6 +- src/scm/webid-oidc/errors.scm | 13 ++++ src/scm/webid-oidc/jwk.scm | 2 + src/scm/webid-oidc/oidc-configuration.scm | 117 ++++++++++++++++++++++++++++++ 4 files changed, 136 insertions(+), 2 deletions(-) create mode 100644 src/scm/webid-oidc/oidc-configuration.scm (limited to 'src') diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 91dff23..ebf6811 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -4,11 +4,13 @@ dist_webidoidcmod_DATA += \ %reldir%/testing.scm \ %reldir%/jwk.scm \ %reldir%/jws.scm \ - %reldir%/cache.scm + %reldir%/cache.scm \ + %reldir%/oidc-configuration.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ %reldir%/testing.go \ %reldir%/jwk.go \ %reldir%/jws.go \ - %reldir%/cache.go + %reldir%/cache.go \ + %reldir%/oidc-configuration.go diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 1476e86..beeaaea 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -217,6 +217,16 @@ (raise-exception ((record-constructor &unexpected-response) response cause))) +(define-public ¬-an-oidc-configuration + (make-exception-type + '¬-an-oidc-configuration + &external-error + '(value cause))) + +(define-public (raise-not-an-oidc-configuration value cause) + (raise-exception + ((record-constructor ¬-an-oidc-configuration) value cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -309,6 +319,9 @@ (lambda (port) (write-response (get 'response) port))) (recurse (get 'cause)))) + ((¬-an-oidc-configuration) + (format #f (G_ "the value ~s is not an OIDC configuration (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm index db7a41f..fd94b9e 100644 --- a/src/scm/webid-oidc/jwk.scm +++ b/src/scm/webid-oidc/jwk.scm @@ -133,6 +133,8 @@ (response-code response) (response-reason-phrase response))) (let ((content-type (response-content-type response))) + (unless content-type + (raise-unexpected-header-value 'content-type content-type)) (unless (and (eq? (car content-type) 'application/json) (or (equal? (assoc-ref (cdr content-type) 'charset) "utf-8") diff --git a/src/scm/webid-oidc/oidc-configuration.scm b/src/scm/webid-oidc/oidc-configuration.scm new file mode 100644 index 0000000..99a4e17 --- /dev/null +++ b/src/scm/webid-oidc/oidc-configuration.scm @@ -0,0 +1,117 @@ +(define-module (webid-oidc oidc-configuration) + #:use-module (webid-oidc jwk) + #:use-module (webid-oidc errors) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-19) + #:use-module (ice-9 receive) + #:use-module (ice-9 optargs)) + +(define-public (the-oidc-configuration x) + (with-exception-handler + (lambda (cause) + (raise-not-an-oidc-configuration x cause)) + (lambda () + (let ((jwks-uri (assq-ref x 'jwks_uri)) + (token-endpoint (assq-ref x 'token_endpoint)) + (authorization-endpoint (assq-ref x 'authorization_endpoint))) + (unless jwks-uri + (raise-missing-alist-key x 'jwks_uri)) + (unless token-endpoint + (raise-missing-alist-key x 'token_endpoint)) + (unless authorization-endpoint + (raise-missing-alist-key x 'authorization_endpoint)) + (for-each + (lambda (field) + (unless (string->uri field) + (scm-error 'wrong-type-arg + "the-oidc-configuration" + "expected an uri-like string" + '() + (list field)))) + (list jwks-uri token-endpoint authorization-endpoint)) + x)))) + +(define-public (oidc-configuration? obj) + (false-if-exception + (and (the-oidc-configuration obj) obj))) + +(define-public (make-oidc-configuration jwks-uri + authorization-endpoint + token-endpoint) + (when (string? jwks-uri) + (set! jwks-uri (string->uri jwks-uri))) + (when (string? authorization-endpoint) + (set! authorization-endpoint (string->uri authorization-endpoint))) + (when (string? token-endpoint) + (set! token-endpoint (string->uri token-endpoint))) + (the-oidc-configuration + `((jwks_uri . ,(uri->string jwks-uri)) + (token_endpoint . ,(uri->string token-endpoint)) + (authorization_endpoint . ,(uri->string authorization-endpoint))))) + +(define (uri-field what) + (lambda (x) + (let ((str (assq-ref (the-oidc-configuration x) what))) + (string->uri str)))) + +(define-public oidc-configuration-jwks-uri + (uri-field 'jwks_uri)) + +(define-public oidc-configuration-authorization-endpoint + (uri-field 'authorization_endpoint)) + +(define-public oidc-configuration-token-endpoint + (uri-field 'token_endpoint)) + +(define-public (oidc-configuration-jwks cfg . args) + (apply get-jwks (oidc-configuration-jwks-uri cfg) args)) + +(define-public (serve-oidc-configuration expiration-date cfg) + (let ((with-solid-oidc-supported + (acons 'solid_oidc_supported "https://solidproject.org/TR/solid-oidc" + (the-oidc-configuration cfg)))) + (values (build-response #:headers `((content-type . (application/json)) + (expires . ,expiration-date))) + (stubs:scm->json-string with-solid-oidc-supported)))) + +(define*-public (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 (cause) + (raise-unexpected-response response cause)) + (lambda () + (unless (eqv? (response-code response) 200) + (raise-request-failed-unexpectedly + (response-code response) + (response-reason-phrase response))) + (let ((content-type (response-content-type response))) + (unless content-type + (raise-unexpected-header-value 'content-type 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)))) + (raise-unexpected-header-value 'content-type content-type)) + (unless (string? response-body) + (set! response-body (utf8->string response-body))) + (the-oidc-configuration (stubs:json-string->scm response-body)))))))) -- cgit v1.2.3