From 34624c72245b483e645efd281a27c9c9e210a19a Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Thu, 14 Oct 2021 11:36:14 +0200 Subject: server: add an identity provider endpoint --- .../server/endpoint/identity-provider.scm | 590 +++++++++++++++++++++ 1 file changed, 590 insertions(+) create mode 100644 src/scm/webid-oidc/server/endpoint/identity-provider.scm (limited to 'src/scm/webid-oidc/server/endpoint/identity-provider.scm') 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 . + +(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 + ( + + configuration + + + subject + encrypted-password + key-file + + + issuer + ;; key-file + + + ;; key-file + + + 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 () + (configuration #:init-keyword #:configuration #:getter configuration)) + +(define-class () + (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 () + (issuer #:init-keyword #:issuer #:getter issuer) + (key-file #:init-keyword #:key-file #:getter key-file)) + +(define-class () + (key-file #:init-keyword #:key-file #:getter key-file)) + +(define-class () + (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 ) initargs) + (next-method) + (unless (equal? (path cfg) "/.well-known/openid-configuration") + (scm-error 'wrong-type-arg "make " + (G_ "#:path must be exactly \"/.well-known/openid-configuration\"") + '() + (list (path cfg)))) + (let-keywords + initargs #t + ((configuration #f)) + (unless (is-a? configuration ) + (scm-error 'wrong-type-arg "make " + (G_ "#:configuration must be an OIDC configuration") + '() + (list configuration))))) + +(define-method (initialize (a ) 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 " + (G_ "#:subject should be an URI") + '() + (list subject)))) + (unless (string? encrypted-password) + (scm-error 'wrong-type-arg "make " + (G_ "#:encrypted-password should be a string") + '() + (list encrypted-password))) + (unless (string? key-file) + (scm-error 'wrong-type-arg "make " + (G_ "#:key-file should be a string") + '() + (list key-file))))) + +(define-method (initialize (t ) 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 " + (G_ "#:subject should be an URI without a path, query or fragment") + '() + (list issuer)))) + (unless (string? key-file) + (scm-error 'wrong-type-arg "make " + (G_ "#:key-file should be a string") + '() + (list key-file))))) + +(define-method (initialize (j ) initargs) + (next-method) + (let-keywords + initargs #t + ((key-file #f)) + (unless (string? key-file) + (scm-error 'wrong-type-arg "make " + (G_ "#:key-file should be a string") + '() + (list key-file))))) + +(define-method (initialize (idp ) 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 ) 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 ) 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_ "

Do you wish to authorize ~a?

") + (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 + (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_ "

The client, ~a, cannot be queried.

") + (uri->string client-id) + (uri->string client-id)) + xml->sxml)) + exn)) + (lambda () + (make + #: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_ "

The real client at ~a does not control the advertised redirection URI.

")) + 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 ) 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_ "

Please use 

application/x-www-form-urlencoded
.

")) + 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_ "

Expected an UTF-8 request body.

")) + 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_ "

This is a token endpoint, please use 

POST
.

")) + 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_ "

No DPoP proof has been found in your request.

")) + 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_ "

The DPoP proof is invalid.

")) + xml->sxml))))) + (lambda () + (decode 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_ "

The 

grant_type
parameter has not been found.

")) + 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_ "

Could not find an authorization code.

")) + 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_ "

The authorization code is invalid.

")) + xml->sxml)) + exn))) + (lambda () + (decode 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_ "

Could not find a refresh token.

")) + 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_ "

The refresh token is invalid or has been revoked.

")) + 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_ "

Cannot process your grant type, ~a.

") + (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 key-file + #:webid webid + #:iss (issuer endpoint) + #:aud client-id)) + (access-token + (issue 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 ) request request-body) + (let ((jwks (make #: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 '()))))) + -- cgit v1.2.3