;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU Affero General Public License as ;; published by the Free Software Foundation, either version 3 of the ;; License, or (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU Affero General Public License for more details. ;; You should have received a copy of the GNU Affero General Public License ;; along with this program. If not, see . (define-module (webid-oidc oidc-configuration) #:use-module (webid-oidc jwk) #:use-module (webid-oidc errors) #:use-module (webid-oidc web-i18n) #: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) #:use-module (ice-9 exceptions) #:use-module (ice-9 match) #:declarative? #t #:export ( &invalid-oidc-configuration 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 )) (define-exception-type &invalid-oidc-configuration &external-error 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 oidc-configuration-token-endpoint (uri-field 'token_endpoint)) (define (oidc-configuration-jwks cfg . args) (apply get-jwks (oidc-configuration-jwks-uri cfg) args)) (define (serve-oidc-configuration expiration-date cfg) (values (build-response #:headers `((content-type . (application/json)) (expires . ,expiration-date))) (stubs:scm->json-string 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))))))))