Fetch a client manifest on the web

3 files changed, 222 insertions, 2 deletions

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: <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))))))
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 &not-a-client-manifest
+  (make-exception-type
+   '&not-a-client-manifest
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-a-client-manifest value cause)
+  (raise-exception
+   ((record-constructor &not-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))))
+          ((&not-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)