Switch to a more sensible error reporting system

1 files changed, 48 insertions, 112 deletions

diff --git a/src/scm/webid-oidc/authorization-page-unsafe.scm b/src/scm/webid-oidc/authorization-page-unsafe.scm
index 1ab235e..a6f5c3b 100644
--- a/src/scm/webid-oidc/authorization-page-unsafe.scm
+++ b/src/scm/webid-oidc/authorization-page-unsafe.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
@@ -19,21 +19,28 @@
   #:use-module (sxml simple)
   #:use-module (web uri)
   #:use-module (web response)
-  #:use-module (ice-9 i18n)
+  #:use-module (webid-oidc web-i18n)
   #:use-module (ice-9 exceptions)
-  #:use-module (ice-9 string-fun))
-
-(define (G_ text)
-  (let ((out (gettext text)))
-    (if (string=? out text)
-        ;; No translation, disambiguate
-        (car (reverse (string-split text #\|)))
-        out)))
+  #:use-module (ice-9 string-fun)
+  #:use-module (ice-9 match)
+  #:use-module (sxml simple)
+  #:use-module (sxml match)
+  #:declarative? #t
+  #:export
+  (
+   authorization-page
+   error-no-client-id
+   error-no-redirect-uri
+   error-application
+   redirection
+   ))
 
 (define (str->sxml str)
-  (cdadr
+  (sxml-match
    (xml->sxml
-    (string-append "<protect>" str "</protect>"))))
+    (string-append "<protect>" str "</protect>"))
+   ((*TOP* (protect ,element ...))
+    (list element ...))))
 
 (define (make-page title . body)
   (with-output-to-string
@@ -42,31 +49,30 @@
        `(*TOP*
          (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
          (html (@ (xmlns "http://www.w3.org/1999/xhtml")
-                  (xml:lang ,(G_ "xml-lang|en")))
+                  (xml:lang ,(W_ "xml-lang|en")))
                (head
                 (title ,title))
                (body
                 ,@body)))))))
 
-(define-public (authorization-page credential-invalid?
-                                   client-id post-uri)
+(define (authorization-page credential-invalid?
+                            client-id post-uri)
   (when (uri? client-id)
     (set! client-id (uri->string client-id)))
   (when (string? post-uri)
     (set! post-uri (string->uri post-uri)))
   (values (build-response
            #:headers `((content-type application/xhtml+xml)))
-          
           (make-page
-           (G_ "page-title|Authorization")
+           (W_ "page-title|Authorization")
            (if (equal?
                 (string->uri client-id)
                 (string->uri
                  "http://www.w3.org/ns/solid/terms#PublicOidcClient"))
-               `(h1 ,@(str->sxml (G_ "Authorize this anonymous application?")))
-               `(h1 ,@(str->sxml (format #f (G_ "Authorize <a href=~s>~a</a>?")
+               `(h1 ,@(str->sxml (W_ "Authorize this anonymous application?")))
+               `(h1 ,@(str->sxml (format #f (W_ "Authorize <a href=~s>~a</a>?")
                                          client-id client-id))))
-           `(p ,@(str->sxml (G_ "Do you want to authorize this application to represent you?")))
+           `(p ,@(str->sxml (W_ "Do you want to authorize this application to represent you?")))
            `(form (@ (action ,(uri->string post-uri))
                      (method "POST"))
                   (div
@@ -76,126 +82,56 @@
                                    '()))
                           ,@(str->sxml
                              (if credential-invalid?
-                                 (G_ "Please retry your password:")
-                                 (G_ "Please enter your password:"))))
+                                 (W_ "Please retry your password:")
+                                 (W_ "Please enter your password:"))))
                    (input (@ (type "password")
                              (name "password")
                              (id "password"))))
                   (input (@ (type "submit")
-                            (value ,(G_ "Allow"))))))))
+                            (value ,(W_ "Allow"))))))))
 
 (define (bad-request . body)
   (values (build-response #:code 400
                           #:reason-phrase "Bad Request"
                           #:headers '((content-type application/xhtml+xml)))
-          (apply make-page (G_ "Bad request") body)))
+          (apply make-page (W_ "Bad request") body)))
 
-(define-public (error-no-client-id)
+(define (error-no-client-id)
   (bad-request
    `(p ,@(str->sxml
-          (G_ "The application did not set the <emph>client_id</emph> parameter.")))))
+          (W_ "The application did not set the <emph>client_id</emph> parameter.")))))
 
-(define-public (error-no-redirect-uri)
+(define (error-no-redirect-uri)
   (bad-request
    `(p ,@(str->sxml
-          (G_ "The application did not set the <emph>redirect_uri</emph> parameter.")))))
+          (W_ "The application did not set the <emph>redirect_uri</emph> parameter.")))))
 
 (define (wrap-error err)
-  (if (record? err)
-      (let* ((type (record-type-descriptor err))
-             (get
-              (lambda (slot)
-                ((record-accessor type slot) err)))
-             (recurse
-              (lambda (err)
-                (wrap-error err))))
-        (case (record-type-name type)
-          ((&not-base64)
-           `((li ,(format #f (G_ "the value ~s is not a base64 string.")
-                          (get 'value)))))
-          ((&not-json)
-           `((li ,(format #f (G_ "the following value is not JSON:"))
-                 (pre ,(get 'value)))))
-          ((&not-turtle)
-           `((li ,(format #f (G_ "the following value is not Turtle:"))
-                 (pre ,(get 'value)))))
-          ((&response-failed-unexpectedly)
-           `((li ,(format #f (G_ "the server request unexpectedly failed with code ~a and reason phrase ~s.")
-                          (get 'response-code) (get 'response-reason-phrase)))))
-          ((&unexpected-header-value)
-           `((li ,(let ((value (get 'value)))
-                    (if value
-                        (format #f (G_ "the header ~a should not have the value ~s.\n")
-                                (get 'header) value)
-                        (format #f (G_ "the header ~a should be present.")
-                                (get 'header)))))))
-          ((&unexpected-response)
-           (cons
-            `(li ,(format #f (G_ "the server response wasn’t expected:"))
-                 (pre ,(call-with-output-string
-                         (lambda (port)
-                           (write-response (get 'response) port)))))
-            (recurse (get 'cause))))
-          ((&incorrect-client-id-field)
-           (let ((value (get 'value)))
-             `((li
-                ,(if value
-                     (format #f (G_ "the client_id field is incorrect: ~s") value)
-                     (G_ "the client_id field is missing"))))))
-          ((&incorrect-redirect-uris-field)
-           (let ((value (get 'value)))
-             `((li
-                ,(if value
-                     (format #f (G_ "the redirect_uris field is incorrect: ~s") value)
-                     (G_ "the redirect_uris field is missing"))))))
-          ((&cannot-fetch-linked-data)
-           (cons
-            `(li ,(format #f (G_ "I could not fetch a RDF graph at ~a;") (uri->string (get 'uri))))
-            (recurse (get 'cause))))
-          ((&not-a-client-manifest)
-           (cons
-            `(li ,(format #f (G_ "this is not a client manifest:"))
-                 (pre ,(format #f "~s" (get 'value))))
-            (recurse (get 'cause))))
-          ((&unauthorized-redirection-uri)
-           (cons
-            `(li ,(format #f (G_ "the manifest does not authorize redirection URI ~a:")
-                          (uri->string (get 'uri)))
-                 (pre ,(format #f "~s" (get 'manifest))))
-            (recurse (get 'cause))))
-          ((&inconsistent-client-manifest-id)
-           `((li ,(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)
-           (cons
-            `(li ,(format #f (G_ "I could not fetch the client manifest of ~a;")
-                          (uri->string (get 'id))))
-            (recurse (get 'cause))))
-          ((&not-an-authorization-code-payload)
-           (cons
-            `(li ,(format #f (G_ "I could not issue an authorization code for you;")))
-            (recurse (get 'cause))))
-          (else
-           (raise-exception err))))
-      (throw err)))
+  (if (message-for-the-user? err)
+      (user-message err)
+      `(p (W_ "Sorry, no more information is available."))))
 
-(define-public (error-application error)
+(define (error-application error)
   (bad-request
-   `(p ,(G_ "The application you are trying to authorize behaved unexpectedly. Here is the explanation of the error:")
-       (ol ,@(wrap-error error)))))
+   `(div
+     (p ,(W_ "The application you are trying to authorize behaved unexpectedly."))
+     ,@(sxml-match
+        (wrap-error error)
+        ((div ,element ...)
+         `(,element ...))
+        (,else `(,else))))))
 
-(define-public (redirection client-id uri)
+(define (redirection client-id uri)
   (values (build-response
            #:code 302
            #:headers `((location . ,uri)
                        (content-type application/xhtml+xml)))
           (make-page
-           (G_ "Redirecting...")
+           (W_ "Redirecting...")
            `(h1 "Authorization granted, you are being redirected")
            `(p ,@(str->sxml
                   (format
                    #f
-                   (G_ "<a href=~s>~a</a> can now log in on your behalf. You still need to adjust permissions.")
+                   (W_ "<p><a href=~s>~a</a> can now log in on your behalf. You still need to adjust permissions.</p>")
                    (uri->string client-id)
                    (uri->string client-id)))))))