Switch to a more sensible error reporting system

1 files changed, 196 insertions, 43 deletions

diff --git a/src/scm/webid-oidc/client-manifest.scm b/src/scm/webid-oidc/client-manifest.scm
index c4b49f0..847fc54 100644
--- a/src/scm/webid-oidc/client-manifest.scm
+++ b/src/scm/webid-oidc/client-manifest.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -17,61 +17,194 @@
 (define-module (webid-oidc client-manifest)
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc fetch)
+  #:use-module (webid-oidc web-i18n)
   #: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 (srfi srfi-26)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 optargs)
   #:use-module (rdf rdf)
-  #:use-module (turtle tordf))
+  #:use-module (turtle tordf)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (sxml match)
+  #:use-module (sxml simple)
+  #:declarative? #t
+  #:export
+  (
 
-(define-public public-oidc-client
+   public-oidc-client
+
+   &invalid-client-manifest
+   make-invalid-client-manifest
+   invalid-client-manifest?
+
+   &unauthorized-redirect-uri
+   make-unauthorized-redirect-uri
+   unauthorized-redirect-uri?
+
+   &inconsistent-client-manifest
+   make-inconsistent-client-manifest
+   inconsistent-client-manifest?
+
+   &cannot-serve-public-manifest
+   make-cannot-serve-public-manifest
+   cannot-serve-public-manifest?
+
+   &cannot-fetch-client-manifest
+   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
+
+   serve-client-manifest
+   get-client-manifest
+
+   ))
+
+(define 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)
+(define-exception-type
+  &invalid-client-manifest
+  &external-error
+  make-invalid-client-manifest
+  invalid-client-manifest?)
+
+(define-exception-type
+  &unauthorized-redirect-uri
+  &external-error
+  make-unauthorized-redirect-uri
+  unauthorized-redirect-uri?)
+
+(define-exception-type
+  &inconsistent-client-manifest
+  &external-error
+  make-inconsistent-client-manifest
+  inconsistent-client-manifest?)
+
+(define-exception-type
+  &cannot-serve-public-manifest
+  &external-error
+  make-cannot-serve-public-manifest
+  cannot-serve-public-manifest?)
+
+(define-exception-type
+  &cannot-fetch-client-manifest
+  &external-error
+  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 (client-manifest? x)
   (false-if-exception
-   (and (the-client-manifest obj) #t)))
+   (the-client-manifest x)))
 
-(define-public (make-client-manifest client-id redirect-uris)
+(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-public (client-manifest-client-id mf)
+(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 (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))))
+  (match uris
+    (()
+     (let ((final-message
+            (format #f (G_ "the client manifest does not allow ~s as a redirection uri")
+                    (uri->string redir)))
+           (final-user-message
+            (sxml-match
+             (xml->sxml (W_ "<p>The application wants to get your
+authorization through <strong>~s</strong>, which is not
+approved.</p>"))
+             ((*TOP* ,element) element))))
+       (raise-exception
+        (make-exception
+         (make-unauthorized-redirect-uri)
+         (make-exception-with-message final-message)
+         (make-message-for-the-user final-user-message)))))
+    (((? (cute equal? <> redir) redir) _ ...)
+     #t)
+    ((_ uris ...)
+     (check-redirect mf uris redir))))
 
-(define-public (client-manifest-check-redirect-uri mf redir)
+(define (client-manifest-check-redirect-uri mf redir)
   (unless (uri? redir)
     (set! redir (string->uri redir)))
   (if (eq? mf public-oidc-client)
@@ -79,12 +212,17 @@
       (let ((redirect-uris
              (assq-ref (the-client-manifest mf) 'redirect_uris)))
         (check-redirect (the-client-manifest mf)
-                        (vector->list redirect-uris)
-                        (uri->string redir)))))
+                        (map string->uri (vector->list redirect-uris))
+                        redir))))
 
-(define-public (serve-client-manifest expiration-date mf)
+(define (serve-client-manifest expiration-date mf)
   (when (eq? mf public-oidc-client)
-    (raise-cannot-serve-public-manifest))
+    (let ((final-message
+           (format #f (G_ "cannot serve the public manifest"))))
+      (raise-exception
+       (make-exception
+        (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)))))
@@ -92,14 +230,25 @@
                                         (expires . ,expiration-date)))
             json-object)))
 
-(define*-public (get-client-manifest id
-                                     #:key
-                                     (http-get http-get))
+(define* (get-client-manifest id
+                              #:key
+                              (http-get http-get))
   (unless (uri? id)
     (set! id (string->uri id)))
   (with-exception-handler
       (lambda (error)
-        (raise-cannot-fetch-client-manifest id 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
@@ -110,9 +259,13 @@
             (when (bytevector? response-body)
               (set! response-body (utf8->string response-body)))
             (let ((mf (the-client-manifest (stubs:json-string->scm response-body))))
-              (unless (equal? (uri->string (client-manifest-client-id mf))
-                              (uri->string id))
-                (raise-inconsistent-client-manifest-id
-                 id
-                 (client-manifest-client-id mf)))
+              (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))))))