diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-14 11:36:14 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-20 18:04:30 +0200 |
commit | 34624c72245b483e645efd281a27c9c9e210a19a (patch) | |
tree | afca30257d8a7c842bd80a4121c69be201c5fdca /src | |
parent | 326f056867bab68ae94408a31af6f4c666dfb191 (diff) |
server: add an identity provider endpoint
Diffstat (limited to 'src')
-rw-r--r-- | src/scm/webid-oidc/Makefile.am | 4 | ||||
-rw-r--r-- | src/scm/webid-oidc/authorization-endpoint.scm | 135 | ||||
-rw-r--r-- | src/scm/webid-oidc/authorization-page-unsafe.scm | 137 | ||||
-rw-r--r-- | src/scm/webid-oidc/authorization-page.scm | 56 | ||||
-rw-r--r-- | src/scm/webid-oidc/identity-provider.scm | 150 | ||||
-rw-r--r-- | src/scm/webid-oidc/oidc-configuration.scm | 2 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/endpoint/Makefile.am | 7 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/endpoint/identity-provider.scm | 590 | ||||
-rw-r--r-- | src/scm/webid-oidc/token-endpoint.scm | 301 |
9 files changed, 742 insertions, 640 deletions
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 92429f7..1d5066b 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -31,8 +31,6 @@ dist_webidoidcmod_DATA += \ %reldir%/authorization-code.scm \ %reldir%/refresh-token.scm \ %reldir%/oidc-id-token.scm \ - %reldir%/authorization-page.scm \ - %reldir%/authorization-page-unsafe.scm \ %reldir%/authorization-endpoint.scm \ %reldir%/token-endpoint.scm \ %reldir%/identity-provider.scm \ @@ -69,8 +67,6 @@ webidoidcgo_DATA += \ %reldir%/authorization-code.go \ %reldir%/refresh-token.go \ %reldir%/oidc-id-token.go \ - %reldir%/authorization-page.go \ - %reldir%/authorization-page-unsafe.go \ %reldir%/authorization-endpoint.go \ %reldir%/token-endpoint.go \ %reldir%/identity-provider.go \ diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm index cbf91cf..74417aa 100644 --- a/src/scm/webid-oidc/authorization-endpoint.scm +++ b/src/scm/webid-oidc/authorization-endpoint.scm @@ -16,10 +16,12 @@ (define-module (webid-oidc authorization-endpoint) #:use-module (webid-oidc errors) - #:use-module (webid-oidc authorization-page) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc server endpoint identity-provider) #:use-module (webid-oidc jwk) #:use-module (webid-oidc authorization-code) #:use-module (webid-oidc client-manifest) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (web request) @@ -30,6 +32,7 @@ #:use-module (ice-9 receive) #:use-module (ice-9 optargs) #:use-module (ice-9 match) + #:use-module (sxml simple) #:use-module (oop goops) #:declarative? #t #:duplicates (merge-generics) @@ -40,97 +43,43 @@ )) -(define (verify-password encrypted-password password) - (let ((c (crypt password encrypted-password))) - (string=? c encrypted-password))) - -(define (make-authorization-endpoint subject encrypted-password jwk) - (define (parse-arg x decode-plus-to-space?) - (map (lambda (x) (uri-decode - x - #:decode-plus-to-space? decode-plus-to-space?)) - (string-split x #\=))) - (lambda* (request request-body) +(define (make-authorization-endpoint subject encrypted-password jwk-file) + (define endpoint + (make <authorization-endpoint> + #:subject subject + #:encrypted-password encrypted-password + #:key-file jwk-file)) + (lambda (request request-body) (when (bytevector? request-body) (set! request-body (utf8->string request-body))) - (let* ((uri (request-uri request)) - (method (request-method request)) - (query (uri-query uri)) - (query-parts (if query - (string-split query #\&) - '())) - (get-args (map (cute parse-arg <> #f) query-parts)) - (form-args - (match (request-content-type request) - ((application/x-www-form-urlencoded . _) - (map (cute parse-arg <> #t) - (string-split request-body #\&))) - (else '()))) - (accept-language - (sort (request-accept-language request) - (lambda (x y) (>= (car x) (car y))))) - (locale - (match accept-language - (((_ . lng) _ ...) lng) - (else "C")))) - (let ((client-id - (match (assoc-ref get-args "client_id") - (((? string->uri client-id) . _) - (string->uri client-id)) - (else #f))) - (redirect-uri - (match (assoc-ref get-args "redirect_uri") - (((? string->uri redirect-uri) . _) - (string->uri redirect-uri)) - (else #f))) - (password - (match (assoc-ref form-args "password") - ((password . _) - password) - (else #f))) - (state - (match (assoc-ref get-args "state") - ((state . _) - state) - (else #f)))) - (cond - ((not client-id) - (error-no-client-id locale)) - ((not redirect-uri) - (error-no-redirect-uri locale)) - ((and (eq? method 'POST) - (string? password) - (verify-password encrypted-password password)) - (with-exception-handler - (lambda (error) - (error-application locale error)) - (lambda () - (let ((code (issue <authorization-code> - jwk - #:webid subject - #:client-id client-id)) - (mf (make <client-manifest> - #:client-id client-id))) - (check-redirect-uri mf redirect-uri) - (let ((query - (if state - (format #f "code=~a&state=~a" - (uri-encode code) - (uri-encode state)) - (format #f "code=~a" - (uri-encode code))))) - (let ((uri - (build-uri 'https - #:userinfo (uri-userinfo redirect-uri) - #:host (uri-host redirect-uri) - #:port (uri-port redirect-uri) - #:path (uri-path redirect-uri) - #:query query))) - (redirection locale client-id uri))))) - #:unwind? #t)) - (else - (authorization-page locale - (not (and password - (verify-password encrypted-password password))) - client-id - uri))))))) + (parameterize ((web-locale request)) + (with-exception-handler + (lambda (exn) + (unless (web-exception? exn) + (raise-exception exn)) + (values + (build-response + #:code (web-exception-code exn) + #:reason-phrase (web-exception-reason-phrase exn) + #:headers `((content-type application/xhtml+xml))) + (call-with-output-string + (cute sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(call-with-input-string + (format #f (W_ "<h1>The authorization request failed</h1>")) + xml->sxml) + ,(if (user-message? exn) + (user-message-sxml exn) + (call-with-input-string + (format #f (W_ "<p>No more information.</p>")) + xml->sxml))))) + <>)))) + (lambda () + (receive (response response-body response-meta) + (handle endpoint request request-body) + (values response response-body))) + #:unwind? #t)))) diff --git a/src/scm/webid-oidc/authorization-page-unsafe.scm b/src/scm/webid-oidc/authorization-page-unsafe.scm deleted file mode 100644 index 640ad53..0000000 --- a/src/scm/webid-oidc/authorization-page-unsafe.scm +++ /dev/null @@ -1,137 +0,0 @@ -;; 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 <https://www.gnu.org/licenses/>. - -(define-module (webid-oidc authorization-page-unsafe) - #:use-module (webid-oidc errors) - #:use-module (sxml simple) - #:use-module (web uri) - #:use-module (web response) - #:use-module (webid-oidc web-i18n) - #:use-module (ice-9 exceptions) - #:use-module (ice-9 string-fun) - #:use-module (ice-9 match) - #:use-module (sxml simple) - #:use-module (sxml match) - #:declarative? #t - #:export - ( - authorization-page - error-no-client-id - error-no-redirect-uri - error-application - redirection - )) - -(define (str->sxml str) - (sxml-match - (xml->sxml - (string-append "<protect>" str "</protect>")) - ((*TOP* (protect ,element ...)) - (list element ...)))) - -(define (make-page title . body) - (with-output-to-string - (lambda () - (sxml->xml - `(*TOP* - (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang ,(W_ "xml-lang|en"))) - (head - (title ,title)) - (body - ,@body))))))) - -(define (authorization-page credential-invalid? - client-id post-uri) - (when (uri? client-id) - (set! client-id (uri->string client-id))) - (when (string? post-uri) - (set! post-uri (string->uri post-uri))) - (values (build-response - #:headers `((content-type application/xhtml+xml))) - (make-page - (W_ "page-title|Authorization") - (if (equal? - (string->uri client-id) - (string->uri - "http://www.w3.org/ns/solid/terms#PublicOidcClient")) - `(h1 ,@(str->sxml (W_ "Authorize this anonymous application?"))) - `(h1 ,@(str->sxml (format #f (W_ "Authorize <a href=~s>~a</a>?") - client-id client-id)))) - `(p ,@(str->sxml (W_ "Do you want to authorize this application to represent you?"))) - `(form (@ (action ,(uri->string post-uri)) - (method "POST")) - (div - (label (@ (for "password") - ,@(if credential-invalid? - '((class "authz-page-credential-error")) - '())) - ,@(str->sxml - (if credential-invalid? - (W_ "Please retry your password:") - (W_ "Please enter your password:")))) - (input (@ (type "password") - (name "password") - (id "password")))) - (input (@ (type "submit") - (value ,(W_ "Allow")))))))) - -(define (bad-request . body) - (values (build-response #:code 400 - #:reason-phrase (W_ "reason-phrase|Bad Request") - #:headers '((content-type application/xhtml+xml))) - (apply make-page (W_ "Bad request") body))) - -(define (error-no-client-id) - (bad-request - `(p ,@(str->sxml - (W_ "The application did not set the <emph>client_id</emph> parameter."))))) - -(define (error-no-redirect-uri) - (bad-request - `(p ,@(str->sxml - (W_ "The application did not set the <emph>redirect_uri</emph> parameter."))))) - -(define (wrap-error err) - (if (message-for-the-user? err) - (user-message err) - `(p (W_ "Sorry, no more information is available.")))) - -(define (error-application error) - (bad-request - `(div - (p ,(W_ "The application you are trying to authorize behaved unexpectedly.")) - ,@(sxml-match - (wrap-error error) - ((div ,element ...) - `(,element ...)) - (,else `(,else)))))) - -(define (redirection client-id uri) - (values (build-response - #:code 302 #:reason-phrase (W_ "reason-phrase|Found") - #:headers `((location . ,uri) - (content-type application/xhtml+xml))) - (make-page - (W_ "Redirecting...") - `(h1 "Authorization granted, you are being redirected") - `(p ,@(str->sxml - (format - #f - (W_ "<p><a href=~s>~a</a> can now log in on your behalf. You still need to adjust permissions.</p>") - (uri->string client-id) - (uri->string client-id))))))) diff --git a/src/scm/webid-oidc/authorization-page.scm b/src/scm/webid-oidc/authorization-page.scm deleted file mode 100644 index 536137e..0000000 --- a/src/scm/webid-oidc/authorization-page.scm +++ /dev/null @@ -1,56 +0,0 @@ -;; 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 <https://www.gnu.org/licenses/>. - -(define-module (webid-oidc authorization-page) - #:use-module (webid-oidc errors) - #:use-module ((webid-oidc web-i18n) #:prefix i18n:) - #:use-module ((webid-oidc authorization-page-unsafe) #:prefix unsafe:) - #:use-module (ice-9 string-fun) - #:use-module (ice-9 receive) - #:use-module (ice-9 threads) - #:declarative? #t - #:export - ( - - authorization-page - error-no-client-id - error-no-redirect-uri - error-application - redirection - - )) - -(define (authorization-page - locale credential-invalid? client-id post-uri) - (parameterize ((i18n:web-locale locale)) - (unsafe:authorization-page credential-invalid? - client-id post-uri))) - -(define (error-no-client-id locale) - (parameterize ((i18n:web-locale locale)) - (unsafe:error-no-client-id))) - -(define (error-no-redirect-uri locale) - (parameterize ((i18n:web-locale locale)) - (unsafe:error-no-redirect-uri))) - -(define (error-application locale error) - (parameterize ((i18n:web-locale locale)) - (unsafe:error-application error))) - -(define (redirection locale client-id uri) - (parameterize ((i18n:web-locale locale)) - (unsafe:redirection client-id uri))) diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm index de56228..5970574 100644 --- a/src/scm/webid-oidc/identity-provider.scm +++ b/src/scm/webid-oidc/identity-provider.scm @@ -18,6 +18,8 @@ #:use-module (webid-oidc errors) #:use-module (webid-oidc authorization-endpoint) #:use-module (webid-oidc token-endpoint) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc server endpoint identity-provider) #:use-module (webid-oidc oidc-configuration) #:use-module (webid-oidc jwk) #:use-module ((webid-oidc config) #:prefix cfg:) @@ -39,6 +41,7 @@ #:use-module (sxml simple) #:use-module (sxml match) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:duplicates (merge-generics) @@ -50,9 +53,16 @@ )) -(define* (same-uri? a b #:key (skip-query #f)) - (and (equal? (uri-path a) (uri-path b)) - (or skip-query (equal? (uri-query a) (uri-query b))))) +(define-class <default> (<endpoint>)) + +(define-method (handle (endpoint <default>) request request-body) + (raise-exception + (make-exception + (make-web-exception 404 (W_ "reason-phrase|Not Found")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>Your request cannot be handled by the identity provider.</p>")) + xml->sxml))))) (define* (make-identity-provider issuer @@ -62,84 +72,64 @@ jwks-uri authorization-endpoint-uri token-endpoint-uri) - (let ((key - (catch #t - (lambda () - (call-with-input-file key-file - (lambda (port) - (jwk->key - (stubs:json->scm port))))) - (lambda error - (format (current-error-port) - (G_ "Warning: generating a new key pair.")) - (let ((k (generate-key #:n-size 2048))) - (stubs:call-with-output-file* - key-file - (lambda (port) - (stubs:scm->json (key->jwk k) port #:pretty #t))) - k))))) - (let ((authorization-endpoint - (make-authorization-endpoint subject encrypted-password key)) - (token-endpoint - (make-token-endpoint token-endpoint-uri issuer key)) - (openid-configuration + (let ((discovery + (make <oidc-discovery> + #:path "/.well-known/openid-configuration" + #:configuration (make <oidc-configuration> #:jwks-uri jwks-uri #:authorization-endpoint authorization-endpoint-uri - #:token-endpoint token-endpoint-uri)) - (openid-configuration-uri - (build-uri 'https - #:host (uri-host issuer) - #:path "/.well-known/openid-configuration"))) + #:token-endpoint token-endpoint-uri))) + (authz + (make <authorization-endpoint> + #:subject subject + #:encrypted-password encrypted-password + #:key-file key-file + #:path (uri-path authorization-endpoint-uri))) + (token + (make <token-endpoint> + #:path (uri-path token-endpoint-uri) + #:issuer issuer + #:key-file key-file)) + (jwks + (make <jwks-endpoint> + #:path (uri-path jwks-uri) + #:key-file key-file))) + (let ((idp (make <identity-provider> + #:oidc-discovery discovery + #:authorization-endpoint authz + #:token-endpoint token + #:jwks-endpoint jwks + #:default (make <default>)))) (lambda (request request-body) - (let ((uri (request-uri request)) - (current-time ((p:current-date)))) - (parameterize ((web-locale request)) - (cond ((same-uri? uri openid-configuration-uri) - (let* ((current-sec (time-second (date->time-utc current-time))) - (exp-sec (+ current-sec 3600)) - (exp (time-utc->date - (make-time time-utc 0 exp-sec)))) - (serve openid-configuration exp))) - ((same-uri? uri jwks-uri) - (let* ((current-sec (time-second (date->time-utc current-time))) - (exp-sec (+ current-sec 3600)) - (exp (time-utc->date - (make-time time-utc 0 exp-sec)))) - (serve (make <jwks> #:keys (list key)) exp))) - ((same-uri? uri authorization-endpoint-uri #:skip-query #t) - (authorization-endpoint request request-body)) - ((same-uri? uri token-endpoint-uri) - (token-endpoint request request-body)) - ((same-uri? uri subject) - (values - (build-response #:headers '((content-type text/turtle)) - #:port #f) - (format #f - "@prefix foaf: <http://xmlns.com/foaf/0.1/> . -@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> . - -<#~a> a foaf:Person ; - rdfs:comment \"It works. Now you should use another service to serve that resource.\" . -" - (uri-fragment subject)))) - (else - (values - (build-response #:code 404 - #:reason-phrase (W_ "reason-phrase|Not Found") - #:headers '((content-type application/xhtml+xml))) - (with-output-to-string - (lambda () - (sxml->xml - `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang ,(W_ "xml-lang|en"))) - (body - ,(sxml-match - (xml->sxml - (W_ (format #f "<h1>Resource not found</h1>"))) - ((*TOP* ,title) title)) - ,(sxml-match - (xml->sxml - (W_ (format #f "<p>This OpenID Connect identity provider does not know the resource you are requesting.</p>"))) - ((*TOP* ,p) p))))))))))))))))) + (parameterize ((web-locale request)) + (with-exception-handler + (lambda (exn) + (unless (web-exception? exn) + (raise-exception exn)) + (values + (build-response + #:code (web-exception-code exn) + #:reason-phrase (web-exception-reason-phrase exn) + #:headers `((content-type application/xhtml+xml))) + (call-with-output-string + (cute sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(call-with-input-string + (format #f (W_ "<h1>The identity provider request failed</h1>")) + xml->sxml) + ,(if (user-message? exn) + (user-message-sxml exn) + (call-with-input-string + (format #f (W_ "<p>No more information.</p>")) + xml->sxml))))) + <>)))) + (lambda () + (receive (response response-body response-meta) + (handle idp request request-body) + (values response response-body))) + #:unwind? #t)))))) diff --git a/src/scm/webid-oidc/oidc-configuration.scm b/src/scm/webid-oidc/oidc-configuration.scm index 094bf8a..9748ab9 100644 --- a/src/scm/webid-oidc/oidc-configuration.scm +++ b/src/scm/webid-oidc/oidc-configuration.scm @@ -183,7 +183,7 @@ (else (raise-exception (make-exception - (make-invalid-oidc-configuratin) + (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"))))))))) diff --git a/src/scm/webid-oidc/server/endpoint/Makefile.am b/src/scm/webid-oidc/server/endpoint/Makefile.am index e6c6158..7248538 100644 --- a/src/scm/webid-oidc/server/endpoint/Makefile.am +++ b/src/scm/webid-oidc/server/endpoint/Makefile.am @@ -18,10 +18,13 @@ dist_endpointserverwebidoidcmod_DATA += \ %reldir%/reverse-proxy.scm \ %reldir%/authentication.scm \ %reldir%/hello.scm \ - %reldir%/client.scm + %reldir%/client.scm \ + %reldir%/identity-provider.scm endpointserverwebidoidcgo_DATA += \ %reldir%/reverse-proxy.go \ %reldir%/authentication.go \ %reldir%/hello.go \ - %reldir%/client.go + %reldir%/client.go \ + %reldir%/identity-provider.go + diff --git a/src/scm/webid-oidc/server/endpoint/identity-provider.scm b/src/scm/webid-oidc/server/endpoint/identity-provider.scm new file mode 100644 index 0000000..d259ce9 --- /dev/null +++ b/src/scm/webid-oidc/server/endpoint/identity-provider.scm @@ -0,0 +1,590 @@ +;; disfluid, implementation of the Solid specification +;; Copyright (C) 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 <https://www.gnu.org/licenses/>. + +(define-module (webid-oidc server endpoint identity-provider) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc authorization-code) + #:use-module (webid-oidc oidc-id-token) + #:use-module (webid-oidc access-token) + #:use-module (webid-oidc dpop-proof) + #:use-module (webid-oidc refresh-token) + #:use-module (webid-oidc oidc-configuration) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc provider-confirmation) + #:use-module (webid-oidc client-manifest) + #:use-module (webid-oidc jwk) + #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module ((webid-oidc config) #:prefix cfg:) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (web server) + #:use-module (web client) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (webid-oidc web-i18n) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) + #:use-module (sxml simple) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (oop goops) + #:use-module (sxml simple) + #:use-module (rnrs bytevectors) + #:duplicates (merge-generics) + #:declarative? #t + #:export + ( + <oidc-discovery> + configuration + + <authorization-endpoint> + subject + encrypted-password + key-file + + <token-endpoint> + issuer + ;; key-file + + <jwks-endpoint> + ;; key-file + + <identity-provider> + oidc-discovery + authorization-endpoint + token-endpoint + jwks-endpoint + default + )) + +(define* (read-key-file key-file #:key (create? #f)) + (define returned #f) + (if create? + (begin + (stubs:atomically-update-file + key-file + (string-append key-file ".lock") + (lambda (output-port) + (catch #t + (lambda () + (call-with-input-file key-file + (lambda (port) + (set! returned + (jwk->key + (stubs:json->scm port)))))) + (lambda error + ;; Generate the key and save it + (set! returned (generate-key #:n-size 2048)))) + ;; Either the key already existed, so we save the exact same + ;; key, or it did not, so we save a new one. + (stubs:scm->json (key->jwk returned) output-port #:pretty #t) + #t)) + returned) + ;; Try to read it first: + (catch #t + (lambda () + (call-with-input-file key-file + (lambda (port) + (jwk->key (stubs:json->scm port))))) + (lambda error + (format (current-error-port) (G_ "Warning: generating a new key pair.\n")) + (read-key-file key-file #:create? #t))))) + +(define-class <oidc-discovery> (<endpoint>) + (configuration #:init-keyword #:configuration #:getter configuration)) + +(define-class <authorization-endpoint> (<endpoint>) + (subject #:init-keyword #:subject #:getter subject) + (encrypted-password #:init-keyword #:encrypted-password #:getter encrypted-password) + (key-file #:init-keyword #:key-file #:getter key-file)) + +(define-class <token-endpoint> (<endpoint>) + (issuer #:init-keyword #:issuer #:getter issuer) + (key-file #:init-keyword #:key-file #:getter key-file)) + +(define-class <jwks-endpoint> (<endpoint>) + (key-file #:init-keyword #:key-file #:getter key-file)) + +(define-class <identity-provider> (<router>) + (oidc-discovery #:init-keyword #:oidc-discovery #:getter oidc-discovery) + (authorization-endpoint #:init-keyword #:authorization-endpoint #:getter authorization-endpoint) + (token-endpoint #:init-keyword #:token-endpoint #:getter token-endpoint) + (jwks-endpoint #:init-keyword #:jwks-endpoint #:getter jwks-endpoint)) + +(define-method (initialize (cfg <oidc-discovery>) initargs) + (next-method) + (unless (equal? (path cfg) "/.well-known/openid-configuration") + (scm-error 'wrong-type-arg "make <oidc-discovery>" + (G_ "#:path must be exactly \"/.well-known/openid-configuration\"") + '() + (list (path cfg)))) + (let-keywords + initargs #t + ((configuration #f)) + (unless (is-a? configuration <oidc-configuration>) + (scm-error 'wrong-type-arg "make <oidc-discovery>" + (G_ "#:configuration must be an OIDC configuration") + '() + (list configuration))))) + +(define-method (initialize (a <authorization-endpoint>) initargs) + (next-method) + (let-keywords + initargs #t + ((subject #f) + (encrypted-password #f) + (key-file #f)) + (match subject + ((? string? (= string->uri (? uri? subject))) + (slot-set! a 'subject subject)) + ((? uri?) #t) + (else + (scm-error 'wrong-type-arg "make <authorization-endpoint>" + (G_ "#:subject should be an URI") + '() + (list subject)))) + (unless (string? encrypted-password) + (scm-error 'wrong-type-arg "make <authorization-endpoint>" + (G_ "#:encrypted-password should be a string") + '() + (list encrypted-password))) + (unless (string? key-file) + (scm-error 'wrong-type-arg "make <authorization-endpoint>" + (G_ "#:key-file should be a string") + '() + (list key-file))))) + +(define-method (initialize (t <token-endpoint>) initargs) + (next-method) + (let-keywords + initargs #t + ((issuer #f) + (key-file #f)) + (match issuer + ((? string? (= string->uri (? uri? issuer))) + (slot-set! t 'issuer issuer)) + ((and (? uri?) + (= uri-path "") + (= uri-query #f) + (= uri-fragment #f)) + #t) + (else + (scm-error 'wrong-type-arg "make <token-endpoint>" + (G_ "#:subject should be an URI without a path, query or fragment") + '() + (list issuer)))) + (unless (string? key-file) + (scm-error 'wrong-type-arg "make <token-endpoint>" + (G_ "#:key-file should be a string") + '() + (list key-file))))) + +(define-method (initialize (j <jwks-endpoint>) initargs) + (next-method) + (let-keywords + initargs #t + ((key-file #f)) + (unless (string? key-file) + (scm-error 'wrong-type-arg "make <jwks-endpoint>" + (G_ "#:key-file should be a string") + '() + (list key-file))))) + +(define-method (initialize (idp <identity-provider>) initargs) + (next-method) + (let-keywords + initargs #t + ((oidc-discovery #f) + (authorization-endpoint #f) + (token-endpoint #f) + (jwks-endpoint #f) + (default #f)) + (match (routed idp) + (((? (cute eq? <> oidc-discovery)) + (? (cute eq? <> authorization-endpoint)) + (? (cute eq? <> token-endpoint)) + (? (cute eq? <> jwks-endpoint)) + (? (cute eq? <> default))) + ;; Recursive initialization done + #t) + (else + ;; Re-initialize with the proper endpoints + (initialize idp + `(#:routed (,oidc-discovery + ,authorization-endpoint + ,token-endpoint + ,jwks-endpoint + ,default) + ,@initargs)))))) + +(define-method (handle (endpoint <oidc-discovery>) request request-body) + (let* ((current-sec (time-second (date->time-utc ((p:current-date))))) + (exp-sec (+ current-sec 3600)) + (exp (time-utc->date + (make-time time-utc 0 exp-sec)))) + (receive (response response-body) + (serve (configuration endpoint) exp) + (values response response-body '())))) + +(define (verify-password encrypted-password password) + (let ((c (crypt password encrypted-password))) + (string=? c encrypted-password))) + +(define (split-args str decode-plus-to-space?) + (apply append + (map + (lambda (k=v) + (catch #t + (lambda () + (match (string-split k=v #\=) + (((= (cute uri-decode <> #:decode-plus-to-space? decode-plus-to-space?) + (= string->symbol key)) + (= uri-decode value)) + `((,key . ,value))) + (else '()))) + (lambda error '()))) + (catch #t + (lambda () + (string-split str #\&)) + (lambda error + '()))))) + +(define-method (handle (endpoint <authorization-endpoint>) request request-body) + (let ((query-args + (split-args + (uri-query (request-uri request)) + #f)) + (form-args + (split-args + (and (match (request-content-type request) + ((or 'application/x-www-form-urlencoded + ('application/x-www-form-urlencoded _ ...)) + #t) + (else #f)) + (if (bytevector? request) + (false-if-exception + (utf8->string request-body)) + request-body)) + #t))) + (let ((client-id + (match (assq-ref query-args 'client_id) + ((? string? (= string->uri (? uri? uri))) + uri) + (else #f))) + (redirect-uri + (match (assq-ref query-args 'redirect_uri) + ((? string? (= string->uri (? uri? uri))) + uri) + (else #f))) + (password (assq-ref form-args 'password)) + (state (assq-ref query-args 'state))) + (define form + (if (uri? client-id) + `(div + ,(call-with-input-string + (format #f (W_ "<h2>Do you wish to authorize <a href=~s>~a</a>?</h2>") + (uri->string client-id) + (uri->string client-id)) + xml->sxml) + (p ,(W_ "If you wish to do so, please type your password:")) + (form (@ (method "post")) + (input (@ (type "password") + (name "password") + (id "password"))) + (input (@ (type "submit") + (value ,(W_ "Allow")))))) + '(p))) + (unless client-id + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + `(p ,(W_ "The client_id query argument is not set.")))))) + (unless redirect-uri + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + `(p ,(W_ "The redirect_uri query argument is not set.")))))) + (if (eq? (request-method request) 'POST) + (begin + (unless (and password (verify-password (encrypted-password endpoint) password)) + (raise-exception + (make-exception + (make-web-exception 401 (W_ "reason-phrase|Unauthorized")) + (make-user-message + `(p ,(W_ "The password is incorrect."))) + (make-user-message form)))) + (let ((code (issue <authorization-code> + (read-key-file (key-file endpoint)) + #:webid (subject endpoint) + #:client-id client-id)) + (mf + (with-exception-handler + (lambda (exn) + (raise-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The client, <a href=~s>~a</a>, cannot be queried.</p>") + (uri->string client-id) + (uri->string client-id)) + xml->sxml)) + exn)) + (lambda () + (make <client-manifest> + #:client-id client-id))))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The real client at <a href=~s>~a</a> does not control the advertised redirection URI.</p>")) + xml->sxml)) + exn)) + (lambda () + (check-redirect-uri mf redirect-uri))) + (values + (build-response + #:code 302 + #:reason-phrase (W_ "reason-phrase|Found") + #:headers `((location + . ,(build-uri 'https + #:userinfo (uri-userinfo redirect-uri) + #:host (uri-host redirect-uri) + #:port (uri-port redirect-uri) + #:path (uri-path redirect-uri) + #:query + (if state + (format #f "code=~a&state=~a" + (uri-encode code) + (uri-encode state)) + (string-append "code=" + (uri-encode code))))) + (content-type application/xhtml+xml))) + (call-with-output-string + (cute sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (head + (title ,(W_ "Redirecting..."))) + (body + (p ,(W_ "You are being redirected."))))) + <>)) + '()))) + (values + (build-response #:headers `((content-type application/xhtml+xml))) + (call-with-output-string + (cute sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (head + (title ,(W_ "Authorization..."))) + (body ,form))) + <>)) + '()))))) + +(define-method (handle (endpoint <token-endpoint>) request request-body) + (unless (match (request-content-type request) + ((or 'application/x-www-form-urlencoded + ('application/x-www-form-urlencoded _ ...)) + #t) + (else #f)) + (raise-exception + (make-exception + (make-web-exception 415 (W_ "reason-phrase|Unsupported Media Type")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>Please use <pre>application/x-www-form-urlencoded</pre>.</p>")) + xml->sxml))))) + (when (bytevector? request-body) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>Expected an UTF-8 request body.</p>")) + xml->sxml)) + exn))) + (lambda () + (set! request-body (utf8->string request-body))))) + (unless (eq? (request-method request) 'POST) + (raise-exception + (make-exception + (make-web-exception 405 (W_ "reason-phrase|Method Not Allowed")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>This is a token endpoint, please use <pre>POST</pre>.</p>")) + xml->sxml))))) + (let ((form-args (split-args request-body #t)) + (true-uri + (let ((server-uri (issuer endpoint))) + (build-uri (uri-scheme server-uri) + #:userinfo (uri-userinfo server-uri) + #:host (uri-host server-uri) + #:port (uri-port server-uri) + #:path (uri-path (request-uri request)) + #:query (uri-query (request-uri request)))))) + (let ((grant-type (assq-ref form-args 'grant_type)) + (dpop + (let ((proof (assq-ref (request-headers request) 'dpop))) + (unless proof + (raise-exception + (make-exception + (make-web-exception 401 (W_ "reason-phrase|Unauthorized")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>No DPoP proof has been found in your request.</p>")) + xml->sxml))))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-web-exception 401 (W_ "reason-phrase|Unauthorized")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The DPoP proof is invalid.</p>")) + xml->sxml))))) + (lambda () + (decode <dpop-proof> proof + #:method (request-method request) + #:uri true-uri + #:cnf/check + (lambda (jkt) #t))))))) + (unless grant-type + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The <pre>grant_type</pre> parameter has not been found.</p>")) + xml->sxml))))) + (receive (webid client-id) + (case (string->symbol grant-type) + ((authorization_code) + (let ((code + (let ((str (assq-ref form-args 'code))) + (unless str + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>Could not find an authorization code.</p>")) + xml->sxml))))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The authorization code is invalid.</p>")) + xml->sxml)) + exn))) + (lambda () + (decode <authorization-code> str + #:issuer-key (read-key-file (key-file endpoint)))))))) + (values (webid code) (client-id code)))) + ((refresh_token) + (let ((refresh-token (assq-ref form-args 'refresh_token))) + (unless refresh-token + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Requeset")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>Could not find a refresh token.</p>")) + xml->sxml))))) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-web-exception 403 (W_ "reason-phrase|Forbidden")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The refresh token is invalid or has been revoked.</p>")) + xml->sxml)) + exn))) + (lambda () + (with-refresh-token refresh-token (jwk dpop) values))))) + (else + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>Cannot process your grant type, ~a.</p>") + (call-with-output-string + (cute sxml->xml `(pre ,grant-type) <>))) + xml->sxml)))))) + ;; So, either from an authorization code or a refresh token, I + ;; have a webid and client-id. + (receive (id-token access-token refresh-token) + (let ((key-file (read-key-file (key-file endpoint)))) + (let ((id-token + (issue <id-token> key-file + #:webid webid + #:iss (issuer endpoint) + #:aud client-id)) + (access-token + (issue <access-token> key-file + #:webid webid + #:iss (issuer endpoint) + #:client-key (jwk dpop) + #:client-id client-id)) + (refresh-token + ;; Reuse it if already present + (if (equal? grant-type "refresh_token") + (assq-ref form-args 'refresh_token) + (issue-refresh-token + webid client-id (jkt (jwk dpop)))))) + (values id-token access-token refresh-token))) + (values + (build-response #:headers '((content-type application/json) + (cache-control (no-cache no-store))) + #:port #f) + (stubs:scm->json-string + `((id_token . ,id-token) + (access_token . ,access-token) + (token_type . "DPoP") + (expires_in . ,(p:oidc-token-default-validity)) + (refresh_token . ,refresh-token))) + `((user . ,webid) + (client-id . ,client-id)))))))) + +(define-method (handle (endpoint <jwks-endpoint>) request request-body) + (let ((jwks (make <jwks> #:keys (list (read-key-file (key-file endpoint)))))) + (let* ((current-sec (time-second (date->time-utc ((p:current-date))))) + (exp-sec (+ current-sec 3600)) + (exp (time-utc->date + (make-time time-utc 0 exp-sec)))) + (receive (response response-body) + (serve jwks exp) + (values response response-body '()))))) + diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm index 53ff1cc..f96e768 100644 --- a/src/scm/webid-oidc/token-endpoint.scm +++ b/src/scm/webid-oidc/token-endpoint.scm @@ -15,6 +15,7 @@ ;; along with this program. If not, see <https://www.gnu.org/licenses/>. (define-module (webid-oidc token-endpoint) + #:use-module (webid-oidc server endpoint identity-provider) #:use-module (webid-oidc errors) #:use-module (webid-oidc server endpoint) #:use-module (webid-oidc authorization-code) @@ -35,6 +36,7 @@ #:use-module (ice-9 control) #:use-module (ice-9 exceptions) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (sxml simple) #:use-module (sxml match) @@ -43,285 +45,50 @@ #:declarative? #t #:export ( - &unsupported-grant-type - make-unsupported-grant-type - unsupported-grant-type? - unsupported-grant-type-grant-type - - &no-authorization-code - make-no-authorization-code - no-authorization-code? - - &no-refresh-token - make-no-refresh-token - no-refresh-token? - make-token-endpoint )) -(define-exception-type - &unsupported-grant-type - &external-error - make-unsupported-grant-type - unsupported-grant-type? - (grant-type unsupported-grant-type-grant-type)) - -(define-exception-type - &no-authorization-code - &external-error - make-no-authorization-code - no-authorization-code?) - -(define-exception-type - &no-refresh-token - &external-error - make-no-refresh-token - no-refresh-token?) - (define (try-handle-web-failure thunk) (call/ec (lambda (return) (with-exception-handler (lambda (error) - (unless (or (unsupported-grant-type? error) - (no-authorization-code? error) - (no-refresh-token? error) - (refresh:invalid-refresh-token? error) - (invalid-authorization-code? error)) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "while handling web failure for the token endpoint: ~a") - (exception-message error)) - (format #f (G_ "an error happened during the token endpoint failure handling"))))) - (raise-exception - (make-exception - (make-exception-with-message final-message) - error)))) - (cond - ((refresh:invalid-refresh-token? error) - (return - (build-response - #:code 403 - #:reason-phrase (G_ "reason-phrase|Forbidden") - #:headers '((content-type application/xhtml-xml))) - (call-with-output-string - (lambda (port) - (sxml->xml - `(*TOP* - (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang ,(W_ "xml-lang|en"))) - (body - ,(sxml-match - (xml->sxml - (W_ (format #f "<h1>Invalid refresh token</h1>"))) - ((*TOP* ,title) title)) - ,(sxml-match - (xml->sxml - (W_ (format #f "<p>The refresh token you sent is invalid, or it is already bound to another key.</p>"))) - ((*TOP* ,p) p)) - ,@(if (user-message? error) - (list (user-message-sxml error)) - '())))) - port))))) - ((invalid-authorization-code? error) - (return - (build-response - #:code 400 - #:reason-phrase (G_ "reason-phrase|Bad Request") - #:headers '((content-type application/xhtml-xml))) - (call-with-output-string - (lambda (port) - (sxml->xml - `(*TOP* - (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang ,(W_ "xml-lang|en"))) - (body - ,(sxml-match - (xml->sxml - (W_ (format #f "<h1>Invalid authorization code</h1>"))) - ((*TOP* ,title) title)) - ,(sxml-match - (xml->sxml - (W_ (format #f "<p>The authorization code is forged, or expired.</p>"))) - ((*TOP* ,p) p)) - ,@(if (user-message? error) - (list (user-message-sxml error)) - '())))) - port))))) - ;; Other bad request - (else - (return - (build-response - #:code 400 - #:reason-phrase (G_ "reason-phrase|Bad Request") - #:headers '((content-type application/xhtml+xml))) - (call-with-output-string - (lambda (port) - (sxml->xml - `(*TOP* - (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang ,(W_ "xml-lang|en"))) - (body - ,(sxml-match - (xml->sxml - (W_ (format #f "<h1>Bad token request</h1>"))) - ((*TOP* ,title) title)) - ,(sxml-match - (xml->sxml - (W_ (format #f "<p>The token request failed.</p>"))) - ((*TOP* ,p) p)) - ,@(if (user-message? error) - (list (user-message-sxml error)) - '())))) - port))))))) + (unless (web-exception? error) + (raise-exception error)) + (return + (build-response + #:code (web-exception-code error) + #:reason-phrase (web-exception-reason-phrase error) + #:headers `((content-type application/xhtml+xml))) + (call-with-output-string + (cute sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(call-with-input-string + (format #f (W_ "<h1>The token request failed</h1>")) + xml->sxml) + ,(if (user-message? error) + (user-message-sxml error) + (call-with-input-string + (format #f (W_ "<p>No more information.</p>")) + xml->sxml))))) + <>)))) thunk)))) -(define (make-token-endpoint token-endpoint-uri iss issuer-key) +(define (make-token-endpoint token-endpoint-uri iss issuer-key-file) + (define endpoint + (make <token-endpoint> + #:issuer iss + #:key-file issuer-key-file)) (lambda (request request-body) (when (bytevector? request-body) (set! request-body (utf8->string request-body))) (try-handle-web-failure (lambda () - (parameterize ((p:current-date ((p:current-date))) - (web-locale request)) - (let ((current-time ((p:current-date))) ;; thunk parameter - (form-args - (if (and (request-content-type request) - (eq? (car (request-content-type request)) - 'application/x-www-form-urlencoded)) - (filter - (lambda (x) x) - (map (lambda (kv) - (let ((parsed - (list->vector - (map (lambda (x) - (uri-decode x #:decode-plus-to-space? #t)) - (string-split kv #\=))))) - (if (eq? (vector-length parsed) 2) - `(,(vector-ref parsed 0) . ,(vector-ref parsed 1)) - #f))) - (string-split request-body #\&))) - '())) - (method (request-method request)) - ;; Maybe we’re behind a reverse proxy, so the authority of - ;; (request-uri request) is meaningless. - (uri (build-uri (uri-scheme token-endpoint-uri) - #:userinfo (uri-userinfo token-endpoint-uri) - #:host (uri-host token-endpoint-uri) - #:port (uri-port token-endpoint-uri) - #:path (uri-path (request-uri request)) - #:query (uri-query (request-uri request))))) - (let ((grant-type (assoc-ref form-args "grant_type")) - (dpop (decode <dpop-proof> (assq-ref (request-headers request) 'dpop) - #:method method - #:uri uri - #:cnf/check - (lambda (jkt) #t)))) - (unless (and grant-type (string? grant-type)) - (let ((final-message - (format #f (G_ "missing grant type"))) - (final-user-message - (sxml-match - (xml->sxml - (format #f (W_ "<p>You did not specify a grant_type for this request.</p>"))) - ((*TOP* ,p) p)))) - (raise-exception - (make-exception - (make-unsupported-grant-type #f) - (make-exception-with-message final-message) - (make-user-message final-user-message))))) - (receive (webid client-id) - (case (string->symbol grant-type) - ((authorization_code) - (let ((code - (let ((str (assoc-ref form-args "code"))) - (unless str - (let ((final-message - (format #f (G_ "missing authorization code"))) - (final-user-message - (sxml-match - (xml->sxml - (format #f (W_ "<p>You want to grant an authorization code, but you did not set one.</p>"))) - ((*TOP* ,p) p)))) - (raise-exception - (make-exception - (make-no-authorization-code) - (make-exception-with-message final-message) - (make-user-message final-user-message))))) - (with-exception-handler - (lambda (error) - (raise-exception - (make-exception - (make-invalid-authorization-code) - error))) - (lambda () - (decode <authorization-code> str - #:issuer-key issuer-key)))))) - (values (webid code) (client-id code)))) - ((refresh_token) - (let ((refresh-token (assoc-ref form-args "refresh_token"))) - (unless refresh-token - (let ((final-message - (format #f (G_ "missing refresh token"))) - (final-user-message - (sxml-match - (xml->sxml - (format #f (W_ "<p>You want to grant a refresh token, but you did not set one.</p>"))) - ((*TOP* ,p) p)))) - (raise-exception - (make-exception - (make-no-refresh-token) - (make-exception-with-message final-message) - (make-user-message final-user-message))))) - (refresh:with-refresh-token - refresh-token - (jwk dpop) - values))) - (else - (let ((final-message - (format #f (G_ "unsupported grant type: ~s") - grant-type)) - (final-user-message - (sxml-match - (xml->sxml - (format #f (W_ "<p>You want to use <pre>~s</pre> as a grant type, but this is not supported.</p>") - grant-type)) - ((*TOP* ,p) p)))) - (raise-exception - (make-exception - (make-unsupported-grant-type grant-type) - (make-exception-with-message final-message) - (make-user-message final-user-message)))))) - (let ((id-token - (issue <id-token> - issuer-key - #:webid webid - #:iss iss - #:aud client-id)) - (access-token - (issue <access-token> - issuer-key - #:webid webid - #:iss iss - #:client-key (jwk dpop) - #:client-id client-id)) - (refresh-token - (if (equal? grant-type "refresh_token") - (assoc-ref form-args "refresh_token") - (refresh:issue-refresh-token webid client-id - (jkt (jwk dpop)))))) - (values - (build-response #:headers '((content-type application/json) - (cache-control (no-cache no-store))) - #:port #f) - (stubs:scm->json-string - `((id_token . ,id-token) - (access_token . ,access-token) - (token_type . "DPoP") - (expires_in . ,(p:oidc-token-default-validity)) - (refresh_token . ,refresh-token))) - client-id - #f)))))))))) + (parameterize ((web-locale request)) + (receive (response response-body response-meta) + (handle endpoint request request-body) + (values response response-body))))))) |