Fetch a client manifest on the web

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))))))