;; 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 serializable) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #: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) #:use-module (oop goops) #:declarative? #t #:export ( &invalid-oidc-configuration make-invalid-oidc-configuratioon invalid-oidc-configuration? jwks-uri authorization-endpoint token-endpoint jwks serve ->json-data )) (define-exception-type &invalid-oidc-configuration &external-error make-invalid-oidc-configuration invalid-oidc-configuration?) (define-class () (jwks-uri #:init-keyword #:jwks-uri #:accessor jwks-uri #:->jwks uri->string) (authorization-endpoint #:init-keyword #:authorization-endpoint #:accessor authorization-endpoint #:->jwks uri->string) (token-endpoint #:init-keyword #:token-endpoint #:accessor token-endpoint #:->jwks uri->string) #:metaclass #:module-name '(webid-oidc oidc-configuration)) (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)) (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) ((p:anonymous-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-configuration) (make-exception-with-message (G_ "when making an OIDC configuration, either its required #:jwks-uri, #:authorization-endpoint and #:token-endpoint fields or #:server or #:json-data should be passed"))))))))) (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-method (serve (cfg ) expiration-date) (values (build-response #:headers `((content-type . (application/json)) (expires . ,expiration-date))) (stubs:scm->json-string (->json-data cfg)))) (define-method (jwks (cfg )) (get-jwks (jwks-uri cfg)))