diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-30 19:51:38 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-04 22:57:58 +0200 |
commit | 9e2873b126bff9e0d13d2953729def4b0b3cd73e (patch) | |
tree | 081f72cb31579300fe4b5228abea8e67ec826897 /src | |
parent | 4a144d76950ac002996c3941c1eb4a5a6de6a661 (diff) |
Client manifest: use GOOPS
Diffstat (limited to 'src')
-rw-r--r-- | src/scm/webid-oidc/authorization-endpoint.scm | 7 | ||||
-rw-r--r-- | src/scm/webid-oidc/client-manifest.scm | 279 |
2 files changed, 146 insertions, 140 deletions
diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm index e859d47..cbf91cf 100644 --- a/src/scm/webid-oidc/authorization-endpoint.scm +++ b/src/scm/webid-oidc/authorization-endpoint.scm @@ -30,7 +30,9 @@ #:use-module (ice-9 receive) #:use-module (ice-9 optargs) #:use-module (ice-9 match) + #:use-module (oop goops) #:declarative? #t + #:duplicates (merge-generics) #:export ( @@ -107,8 +109,9 @@ jwk #:webid subject #:client-id client-id)) - (mf (get-client-manifest client-id))) - (client-manifest-check-redirect-uri mf redirect-uri) + (mf (make <client-manifest> + #:client-id client-id))) + (check-redirect-uri mf redirect-uri) (let ((query (if state (format #f "code=~a&state=~a" diff --git a/src/scm/webid-oidc/client-manifest.scm b/src/scm/webid-oidc/client-manifest.scm index 7ea4931..dd29152 100644 --- a/src/scm/webid-oidc/client-manifest.scm +++ b/src/scm/webid-oidc/client-manifest.scm @@ -18,6 +18,7 @@ #:use-module (webid-oidc errors) #:use-module (webid-oidc fetch) #: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) @@ -33,12 +34,11 @@ #:use-module (ice-9 match) #:use-module (sxml match) #:use-module (sxml simple) + #:use-module (oop goops) #:declarative? #t #:export ( - public-oidc-client - &invalid-client-manifest make-invalid-client-manifest invalid-client-manifest? @@ -59,19 +59,16 @@ make-cannot-fetch-client-manifest cannot-fetch-client-manifest? - the-client-manifest - client-manifest? - make-client-manifest - client-manifest-client-id - client-manifest-check-redirect-uri + <client-manifest> + client-id + redirect-uris - serve-client-manifest - get-client-manifest + ->json-data - )) + check-redirect-uri + serve -(define public-oidc-client - 'public-oidc-client) + )) (define-exception-type &invalid-client-manifest @@ -103,84 +100,129 @@ make-cannot-fetch-client-manifest cannot-fetch-client-manifest?) -(define (the-client-manifest x) - (with-exception-handler - (lambda (error) - (let ((sysadmin-message - (if (exception-with-message? error) - (format #f (G_ "this is not a client manifest: ~a") - (exception-message error)) - (format #f (G_ "this is not a client manifest")))) - (user-message - (let ((new-paragraph - (sxml-match - (xml->sxml (W_ "<p>The client manifest could -not be queried. It can be because the client application is down, or -it is incomplete, or unusable for other reasons.</p>")) - ((*TOP* ,element) - element)))) - (if (message-for-the-user? error) - (sxml-match - (user-message error) - ((div ,element ...) - `(div ,new-paragraph ,element ...)) - (,element - `(div ,new-paragraph ,element))) - new-paragraph)))) - (raise-exception - (make-exception - (make-invalid-client-manifest) - (make-exception-with-message sysadmin-message) - (make-message-for-the-user user-message) - error)))) - (lambda () - (let examine-fields ((fields x) - (client-id #f) - (redirect-uris #f) - (other-fields '())) - (match fields - (() - (unless (and client-id redirect-uris) - (fail (format #f (G_ "the client manifest is missing ~s") - (apply append - `(,@(if client-id '() '("client_id")) - ,@(if redirect-uris '() '("redirect_uris"))))))) - `((client_id . ,(uri->string client-id)) - (redirect_uris . ,(list->vector (map uri->string redirect-uris))) - ,@(reverse other-fields))) - ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) fields ...) - (examine-fields fields (or client-id client-id-given) - redirect-uris other-fields)) - ((('client_id . invalid) _ ...) - (fail (format #f (G_ "~s is an invalid \"client_id\" value, because it is not an URI") - invalid))) - ((('redirect_uris . #((? string? (= string->uri (? uri? uri))) ...)) fields ...) - (examine-fields fields client-id (or redirect-uris uri) other-fields)) - ((('redirect_uris . #(_ ...)) _ ...) - (fail (format #f (G_ "at least one of the redirect URIs is not a proper URI")))) - ((('redirect_uris . _) _ ...) - (fail (format #f (G_ "the \"redirect_uris\" field should be a vector of URIs")))) - ((other-field fields ...) - (examine-fields fields client-id redirect-uris - `(,other-field ,@other-fields))) - (else - (fail (format #f (G_ "the client manifest should be a JSON object"))))))))) +(define public-client-uri + (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient")) -(define (client-manifest? x) - (false-if-exception - (the-client-manifest x))) +(define-class <client-manifest> () + (client-id #:init-keyword #:client-id #:accessor client-id #:->jwks uri->string) + (redirect-uris #:init-keyword #:redirect-uris #:accessor redirect-uris #:->jwks uri->string) + #:metaclass <plugin-class> + #:module-name '(webid-oidc client-manifest)) -(define (make-client-manifest client-id redirect-uris) - (the-client-manifest - `((client_id . ,(uri->string client-id)) - (redirect_uris . ,(list->vector - (map uri->string - redirect-uris)))))) - -(define (client-manifest-client-id mf) - (if (eq? mf public-oidc-client) - (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient") - (string->uri (assq-ref (the-client-manifest mf) 'client_id)))) +(define-method (initialize (client <client-manifest>) initargs) + (next-method) + (let-keywords + initargs #t + ((client-id #f) + (redirect-uris #f)) + (let do-initialize ((client-id client-id) + (redirect-uris redirect-uris)) + (when (list? redirect-uris) + (set! redirect-uris + (map + (match-lambda + ((or (? string? (= string->uri (? uri? value))) + value) + value)) + redirect-uris))) + (cond + ((string? client-id) + (do-initialize (string->uri client-id) redirect-uris)) + ((equal? client-id public-client-uri) + (slot-set! client 'client-id client-id) + (slot-set! client 'redirect-uris '())) + ((not redirect-uris) + (receive (response response-body) ((p:anonymous-http-request) client-id) + (with-exception-handler + (lambda (error) + (raise-exception + (make-exception + (make-cannot-fetch-client-manifest) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "cannot fetch a client manifest: ~a") + (exception-message error)) + (format #f (G_ "cannot fetch a client manifest")))) + error))) + (lambda () + (when (bytevector? response-body) + (set! response-body (utf8->string response-body))) + (unless (eqv? (response-code response) 200) + (raise-exception + (make-exception + (make-exception-with-message + (format #f (G_ "the server responded with code ~a") + (response-code response))) + (make-message-for-the-user + `(p ,(format #f (W_ "The server hosting your application responded with code ~a.") + (response-code response))))))) + (let ((json-data (stubs:json-string->scm response-body))) + (let ((new-client-id (assq-ref json-data 'client_id)) + (redirect-uris (assq-ref json-data 'redirect_uris))) + (unless (string? new-client-id) + (raise-exception + (make-exception + (make-exception-with-message + (G_ "the client manifest does not have a client_id field")) + (make-message-for-the-user + `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the client_id field.")))))) + (set! redirect-uris + (let fix-redirect-uris ((redirect-uris redirect-uris)) + (match redirect-uris + ((? vector? (= vector->list redirect-uris)) + redirect-uris) + ((? list? redirect-uris) + (map fix-redirect-uris redirect-uris)) + ((? string? (= string->uri (? uri? uri))) + uri) + (anything anything)))) + (set! new-client-id + (match new-client-id + ((? string? (= string->uri (? uri? uri))) + uri) + (anything anything))) + (unless redirect-uris + (raise-exception + (make-exception + (make-exception-with-message + (G_ "the client manifest does not have a redirect_uris field")) + (make-message-for-the-user + `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the redirect_uris field.")))))) + (unless new-client-id + (raise-exception + (make-exception + (make-exception-with-message + (G_ "the client manifest does not have a client_id field")) + (make-message-for-the-user + `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the client_id field.")))))) + (unless (equal? client-id new-client-id) + (raise-exception + (make-exception + (make-inconsistent-client-manifest) + (make-exception-with-message + (format #f (G_ "the client manifest under ~s has a client_id of ~s") + (uri->string client-id) + (uri->string new-client-id))) + (make-message-for-the-user + `(p ,(W_ "The application you want to use does not control the domain name it appears to represent.")))))) + (do-initialize new-client-id redirect-uris))))))) + (else + (unless (uri? client-id) + (scm-error 'wrong-type-arg "make" + (G_ "#:client-id should be an URI") + '() + (list client-id))) + (unless (let check-redirect-uris ((redirect-uris redirect-uris)) + (match redirect-uris + (() #t) + (((? uri?) redirect-uris ...) + (check-redirect-uris redirect-uris)))) + (scm-error 'wrong-type-arg "make" + (G_ "#:redirect-uris should be a list of URIs") + '() + (list redirect-uri))) + (slot-set! client 'client-id client-id) + (slot-set! client 'redirect-uris redirect-uris)))))) (define (check-redirect mf uris redir) (match uris @@ -204,19 +246,19 @@ approved.</p>")) ((_ uris ...) (check-redirect mf uris redir)))) -(define (client-manifest-check-redirect-uri mf redir) +(define-method (check-redirect-uri (mf <client-manifest>) redir) (unless (uri? redir) (set! redir (string->uri redir))) - (if (eq? mf public-oidc-client) - #t - (let ((redirect-uris - (assq-ref (the-client-manifest mf) 'redirect_uris))) - (check-redirect (the-client-manifest mf) - (map string->uri (vector->list redirect-uris)) - redir)))) + (or (equal? (client-id mf) public-client-uri) + (check-redirect mf (redirect-uris mf) redir))) + +(define-method (->json-data (mf <client-manifest>)) + `((@context . "https://www.w3.org/ns/solid/oidc-context.jsonld") + (client_id . ,(uri->string (client-id mf))) + (redirect_uris . ,(list->vector (map uri->string (redirect-uris mf)))))) -(define (serve-client-manifest expiration-date mf) - (when (eq? mf public-oidc-client) +(define-method (serve (mf <client-manifest>) expiration-date) + (when (equal? (client-id mf) public-client-uri) (let ((final-message (format #f (G_ "cannot serve the public manifest")))) (raise-exception @@ -224,46 +266,7 @@ approved.</p>")) (make-cannot-serve-public-manifest) (make-exception-with-message final-message))))) (let ((json-object (stubs:scm->json-string - `((@context . "https://www.w3.org/ns/solid/oidc-context.jsonld") - ,@(the-client-manifest mf))))) + (->json-data mf)))) (values (build-response #:headers `((content-type application/ld+json) (expires . ,expiration-date))) json-object))) - -(define* (get-client-manifest id) - (unless (uri? id) - (set! id (string->uri id))) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "cannot fetch the client manifest ~s: ~a") - (uri->string id) - (exception-message error)) - (format #f (G_ "cannot fetch the client manifest ~s") - (uri->string id))))) - (raise-exception - (make-exception - (make-cannot-fetch-client-manifest) - (make-exception-with-message final-message) - error)))) - (lambda () - (if (equal? id - (string->uri - "http://www.w3.org/ns/solid/terms#PublicOidcClient")) - public-oidc-client - (receive (response response-body) - ((p:anonymous-http-request) id) - (when (bytevector? response-body) - (set! response-body (utf8->string response-body))) - (let ((mf (the-client-manifest (stubs:json-string->scm response-body)))) - (unless (equal? (client-manifest-client-id mf) id) - (let ((final-message - (format #f (G_ "the client manifest is dereferenced from ~s, but it pretends to be ~s") - (uri->string id) - (uri->string (client-manifest-client-id mf))))) - (raise-exception - (make-exception - (make-inconsistent-client-manifest) - (make-exception-with-message final-message))))) - mf)))))) |