From 197da00a94a2fecee59c5d7a090316e9dd82fe90 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Mon, 30 Nov 2020 23:13:17 +0100 Subject: Fetch a client manifest on the web --- src/scm/webid-oidc/Makefile.am | 6 +- src/scm/webid-oidc/client-manifest.scm | 126 +++++++++++++++++++++++++++++++++ src/scm/webid-oidc/errors.scm | 92 ++++++++++++++++++++++++ 3 files changed, 222 insertions(+), 2 deletions(-) create mode 100644 src/scm/webid-oidc/client-manifest.scm (limited to 'src') diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 31c23ab..709eb1b 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -9,7 +9,8 @@ dist_webidoidcmod_DATA += \ %reldir%/access-token.scm \ %reldir%/jti.scm \ %reldir%/dpop-proof.scm \ - %reldir%/fetch.scm + %reldir%/fetch.scm \ + %reldir%/client-manifest.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ @@ -21,4 +22,5 @@ webidoidcgo_DATA += \ %reldir%/access-token.go \ %reldir%/jti.go \ %reldir%/dpop-proof.go \ - %reldir%/fetch.go + %reldir%/fetch.go \ + %reldir%/client-manifest.go diff --git a/src/scm/webid-oidc/client-manifest.scm b/src/scm/webid-oidc/client-manifest.scm new file mode 100644 index 0000000..54c098a --- /dev/null +++ b/src/scm/webid-oidc/client-manifest.scm @@ -0,0 +1,126 @@ +(define-module (webid-oidc client-manifest) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc fetch) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (web uri) + #:use-module (web client) + #: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 (rdf rdf) + #:use-module (turtle tordf)) + +(define-public public-oidc-client + 'public-oidc-client) + +(define-public (all-uris x) + (or (null? x) + (and (string->uri (car x)) + (all-uris (cdr x))))) + +(define-public (the-client-manifest x) + (if (eq? x public-oidc-client) + public-oidc-client + (let ((client-id (assq-ref x 'client_id)) + (redirect-uris (assq-ref x 'redirect_uris))) + (unless (and client-id (string? client-id) (string->uri client-id)) + (raise-incorrect-client-id-field client-id)) + (unless (and redirect-uris + (vector? redirect-uris) + (all-uris (vector->list redirect-uris))) + (raise-incorrect-redirect-uris-field redirect-uris)) + x))) + +(define-public (client-manifest? obj) + (false-if-exception + (and (the-client-manifest obj) #t))) + +(define-public (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-public (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 (check-redirect mf uris redir) + (if (null? uris) + (raise-unauthorized-redirection-uri mf (string->uri redir)) + (or (string=? (car uris) redir) + (check-redirect mf (cdr uris) redir)))) + +(define-public (client-manifest-check-redirect-uri mf 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) + (vector->list redirect-uris) + (uri->string redir))))) + +(define (turtle-escape str) + (define (folder c other) + (if (or (eq? c #\\) (eq? c #\")) + (cons* c #\\ other) + (cons c other))) + (list->string (reverse (string-fold folder '() str)))) + +(define-public (serve-client-manifest expiration-date mf) + (when (eq? mf public-oidc-client) + (raise-cannot-serve-public-manifest)) + (let ((json-object (stubs:scm->json-string (the-client-manifest mf))) + (id (uri->string (client-manifest-client-id (the-client-manifest mf))))) + (let ((resource (string-append " +@prefix solid: . + +<" id "> solid:oidcRegistration \"\"\" +" (turtle-escape json-object) " +\"\"\" . +"))) + (values (build-response #:headers `((content-type text/turtle) + (expires . ,expiration-date))) + resource)))) + +(define (find-registration id graph) + (cond ((null? graph) + (raise-no-client-manifest-registration (string->uri id))) + ((and (string=? (rdf-triple-predicate (car graph)) + "http://www.w3.org/ns/solid/terms#oidcRegistration") + (string? (rdf-triple-subject (car graph))) + (string=? (rdf-triple-subject (car graph)) id) + (rdf-literal? (rdf-triple-object (car graph))) + (string=? (rdf-literal-type (rdf-triple-object (car graph))) + "http://www.w3.org/2001/XMLSchema#string")) + (let ((object (rdf-triple-object (car graph)))) + (let ((ret (stubs:json-string->scm (rdf-literal-lexical-form object)))) + (if (client-manifest? ret) + (begin + (unless (equal? (uri->string (client-manifest-client-id ret)) + id) + (raise-inconsistent-client-manifest-id (string->uri id) + (client-manifest-client-id ret))) + ret) + (find-registration id (cdr graph)))))) + (else (find-registration id (cdr graph))))) + +(define*-public (get-client-manifest id + #:key + (http-get http-get)) + (with-exception-handler + (lambda (error) + (raise-cannot-fetch-client-manifest id error)) + (lambda () + (if (equal? id + (string->uri + "http://www.w3.org/ns/solid/terms#PublicOidcClient")) + public-oidc-client + (let ((graph (fetch id #:http-get http-get))) + (find-registration (uri->string id) graph)))))) diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 2dc9edc..d6f685a 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -309,6 +309,16 @@ (raise-exception ((record-constructor &incorrect-client-id-field) value))) +(define-public &incorrect-redirect-uris-field + (make-exception-type + '&incorrect-redirect-uris-field + &external-error + '(value))) + +(define-public (raise-incorrect-redirect-uris-field value) + (raise-exception + ((record-constructor &incorrect-redirect-uris-field) value))) + (define-public &incorrect-typ-field (make-exception-type '&incorrect-typ-field @@ -549,6 +559,66 @@ (raise-exception ((record-constructor &cannot-fetch-linked-data) uri cause))) +(define-public ¬-a-client-manifest + (make-exception-type + '¬-a-client-manifest + &external-error + '(value cause))) + +(define-public (raise-not-a-client-manifest value cause) + (raise-exception + ((record-constructor ¬-a-client-manifest) value cause))) + +(define-public &unauthorized-redirection-uri + (make-exception-type + '&unauthorized-redirection-uri + &external-error + '(manifest uri))) + +(define-public (raise-unauthorized-redirection-uri manifest uri) + (raise-exception + ((record-constructor &unauthorized-redirection-uri) manifest uri))) + +(define-public &cannot-serve-public-manifest + (make-exception-type + '&cannot-serve-public-manifest + &external-error + '())) + +(define-public (raise-cannot-serve-public-manifest) + (raise-exception + ((record-constructor &cannot-serve-public-manifest)))) + +(define-public &no-client-manifest-registration + (make-exception-type + '&no-client-manifest-registration + &external-error + '(id))) + +(define-public (raise-no-client-manifest-registration id) + (raise-exception + ((record-constructor &no-client-manifest-registration) id))) + +(define-public &inconsistent-client-manifest-id + (make-exception-type + '&inconsistent-client-manifest-id + &external-error + '(id advertised-id))) + +(define-public (raise-inconsistent-client-manifest-id id advertised-id) + (raise-exception + ((record-constructor &inconsistent-client-manifest-id) id advertised-id))) + +(define-public &cannot-fetch-client-manifest + (make-exception-type + '&cannot-fetch-client-manifest + &external-error + '(id cause))) + +(define-public (raise-cannot-fetch-client-manifest id cause) + (raise-exception + ((record-constructor &cannot-fetch-client-manifest) id cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -682,6 +752,11 @@ (if value (format #f (G_ "the client-id field is incorrect: ~s") value) (format #f (G_ "the client-id field is missing"))))) + ((&incorrect-redirect-uris-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the redirect_uris field is incorrect: ~s") value) + (format #f (G_ "the redirect_uris field is missing"))))) ((&incorrect-typ-field) (let ((value (get 'value))) (if value @@ -787,6 +862,23 @@ ((&cannot-fetch-linked-data) (format #f (G_ "I could not fetch a RDF graph at ~a (because ~a)") (uri->string (get 'uri)) (recurse (get 'cause)))) + ((¬-a-client-manifest) + (format #f (G_ "~s is not a client manifest (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((&unauthorized-redirection-uri) + (format #f (G_ "~s does not authorize redirection URI ~a") + (get 'manifest) (uri->string (get 'uri)))) + ((&cannot-serve-public-manifest) + (format #f (G_ "I cannot serve a public manifest"))) + ((&no-client-manifest-registration) + (format #f (G_ "~a does not have a client manifest registration triple") + (uri->string (get 'id)))) + ((&inconsistent-client-manifest-id) + (format #f (G_ "the client manifest at ~a is advertised for ~a") + (uri->string (get 'id)) (uri->string (get 'advertised-id)))) + ((&cannot-fetch-client-manifest) + (format #f (G_ "I could not fetch the client manifest of ~a (because ~a)") + (uri->string (get 'id)) (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) -- cgit v1.2.3