diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2020-11-30 23:13:17 +0100 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-06-19 15:44:36 +0200 |
commit | 197da00a94a2fecee59c5d7a090316e9dd82fe90 (patch) | |
tree | 1487ba9452b79703773e3855933ace5194e94bce /src/scm/webid-oidc/client-manifest.scm | |
parent | 37c019d143a70bc6261eb8addcb24550b829e9bb (diff) |
Fetch a client manifest on the web
Diffstat (limited to 'src/scm/webid-oidc/client-manifest.scm')
-rw-r--r-- | src/scm/webid-oidc/client-manifest.scm | 126 |
1 files changed, 126 insertions, 0 deletions
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: <http://www.w3.org/ns/solid/terms#> . + +<" 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)))))) |