;; 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-configuratin)
(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)))