server: add an exception for showing a message to the user

4 files changed, 99 insertions, 48 deletions

diff --git a/src/scm/webid-oidc/client-manifest.scm b/src/scm/webid-oidc/client-manifest.scm
index 1d855c1..2d1f428 100644
--- a/src/scm/webid-oidc/client-manifest.scm
+++ b/src/scm/webid-oidc/client-manifest.scm
@@ -16,6 +16,7 @@
 
 (define-module (webid-oidc client-manifest)
   #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc server endpoint)
   #:use-module (webid-oidc fetch)
   #:use-module (webid-oidc web-i18n)
   #:use-module (webid-oidc serializable)
@@ -153,9 +154,11 @@
                  (make-exception-with-message
                   (format #f (G_ "the server responded with code ~a")
                           (response-code response)))
-                 (make-message-for-the-user
-                  `(p ,(format #f (W_ "The server hosting your application responded with code ~a.")
-                               (response-code response)))))))
+                 (make-user-message
+                  (call-with-input-string
+                      (format #f (W_ "<p>The server hosting your application responded with code ~a.<p>")
+                              (response-code response))
+                    xml->sxml)))))
              (let ((json-data (stubs:json-string->scm response-body)))
                (let ((new-client-id (assq-ref json-data 'client_id))
                      (redirect-uris (assq-ref json-data 'redirect_uris)))
@@ -164,8 +167,10 @@
                     (make-exception
                      (make-exception-with-message
                       (G_ "the client manifest does not have a client_id field"))
-                     (make-message-for-the-user
-                      `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the client_id field."))))))
+                     (make-user-message
+                      (call-with-input-string
+                          (format #f (W_ "<p>The server hosting your application does not behave correctly, because it lacks the client_id field.<p>"))
+                        xml->sxml)))))
                  (set! redirect-uris
                        (let fix-redirect-uris ((redirect-uris redirect-uris))
                          (match redirect-uris
@@ -186,15 +191,19 @@
                     (make-exception
                      (make-exception-with-message
                       (G_ "the client manifest does not have a redirect_uris field"))
-                     (make-message-for-the-user
-                      `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the redirect_uris field."))))))
+                     (make-user-message
+                      (call-with-input-string
+                          (format #f (W_ "<p>The server hosting your application does not behave correctly, because it lacks the redirect_uris field.<p>"))
+                        xml->sxml)))))
                  (unless new-client-id
                    (raise-exception
                     (make-exception
                      (make-exception-with-message
                       (G_ "the client manifest does not have a client_id field"))
-                     (make-message-for-the-user
-                      `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the client_id field."))))))
+                     (make-user-message
+                      (call-with-input-string
+                          (format #f (W_ "<p>The server hosting your application does not behave correctly, because it lacks the client_id field.<p>"))
+                        xml->sxml)))))
                  (unless (equal? client-id new-client-id)
                    (raise-exception
                     (make-exception
@@ -203,8 +212,10 @@
                       (format #f (G_ "the client manifest under ~s has a client_id of ~s")
                               (uri->string client-id)
                               (uri->string new-client-id)))
-                     (make-message-for-the-user
-                      `(p ,(W_ "The application you want to use does not control the domain name it appears to represent."))))))
+                     (make-user-message
+                      (call-with-input-string
+                          (format #f (W_ "<p>The application you want to use does not control the domain name it appears to represent.</p>"))
+                        xml->sxml)))))
                  (do-initialize new-client-id redirect-uris)))))))
       (else
        (unless (uri? client-id)
@@ -231,16 +242,18 @@
             (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))))
+            (call-with-input-string
+                (format #f (W_ "<p>The application wants to get your
+authorization through <strong>~a</strong>, which is not
+approved.</p>")
+                        (call-with-output-string
+                          (cute sxml->xml `(*TOP* ,(uri->string redir)) <>)))
+              xml->sxml)))
        (raise-exception
         (make-exception
          (make-unauthorized-redirect-uri)
          (make-exception-with-message final-message)
-         (make-message-for-the-user final-user-message)))))
+         (make-user-message final-user-message)))))
     (((? (cute equal? <> redir) redir) _ ...)
      #t)
     ((_ uris ...)
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index aabb6ea..6efc6c8 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -25,24 +25,9 @@
   #:declarative? #t
   #:export
   (
-   &message-for-the-user
-   make-message-for-the-user
-   message-for-the-user?
-   user-message
-
    fail
    ))
 
-;; A message to show the user is an XHTML paragraph or equivalent (as
-;; sxml). A div is used to contain multiple messages.
-
-(define-exception-type
-  &message-for-the-user
-  &external-error
-  make-message-for-the-user
-  message-for-the-user?
-  (message user-message))
-
 (define (fail message)
   ;; Like error, but don’t do funny things when message is not a
   ;; string literal
diff --git a/src/scm/webid-oidc/server/endpoint.scm b/src/scm/webid-oidc/server/endpoint.scm
index d327139..9a19ceb 100644
--- a/src/scm/webid-oidc/server/endpoint.scm
+++ b/src/scm/webid-oidc/server/endpoint.scm
@@ -48,8 +48,62 @@
    routed
 
    handle
+
+   &web-exception
+   make-web-exception
+   web-exception?
+   web-exception-code
+   web-exception-reason-phrase
+
+   &caused-by-user
+   make-caused-by-user
+   caused-by-user?
+   caused-by-user-webid
+
+   &user-message
+   make-user-message
+   user-message?
+   user-message-sxml
    ))
 
+(define-exception-type
+  &web-exception
+  &external-error
+  make-web-exception
+  web-exception?
+  (code web-exception-code)
+  (reason-phrase web-exception-reason-phrase))
+
+(define-exception-type
+  &caused-by-user
+  &external-error
+  make-caused-by-user
+  caused-by-user?
+  (webid caused-by-user-webid))
+
+(define-exception-type
+  &user-message
+  &external-error
+  make-user-message
+  user-message?
+  (sxml user-message-one-sxml))
+
+(define (user-message-sxml exn)
+  (let loop ((components (simple-exceptions exn))
+             (gathered '()))
+    (match components
+      (()
+       (match gathered
+         (()
+          `(div ,(W_ "No information available.")))
+         ((= reverse gathered)
+          `(div ,@gathered))))
+      (((? user-message? (= user-message-one-sxml next))
+        components ...)
+       (loop components `(,next ,@gathered)))
+      ((_ components ...)
+       (loop components gathered)))))
+
 (define-class <endpoint> ()
   (host #:init-keyword #:host #:getter host #:init-value #f)
   (path #:init-keyword #:path #:getter path  #:init-value "/"))
@@ -122,12 +176,10 @@
   (let find-router ((routed (routed endpoint)))
     (match routed
       (()
-       (values
-        (build-response
-         #:code 404
-         #:reason-phrase (W_ "Not Found"))
-        #f
-        '()))
+       (raise-exception
+        (make-exception
+         (make-web-exception 404 (W_ "Not Found"))
+         (make-user-message (W_ "The resource could not be found.")))))
       (((and router
              (? (cute relevant? <> request)))
         _ ...)
diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm
index a10c843..53ff1cc 100644
--- a/src/scm/webid-oidc/token-endpoint.scm
+++ b/src/scm/webid-oidc/token-endpoint.scm
@@ -16,6 +16,7 @@
 
 (define-module (webid-oidc token-endpoint)
   #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc server endpoint)
   #:use-module (webid-oidc authorization-code)
   #:use-module (webid-oidc dpop-proof)
   #:use-module (webid-oidc jws)
@@ -119,8 +120,8 @@
                               (xml->sxml
                                (W_ (format #f "<p>The refresh token you sent is invalid, or it is already bound to another key.</p>")))
                               ((*TOP* ,p) p))
-                            ,@(if (message-for-the-user? error)
-                                  (user-message error)
+                            ,@(if (user-message? error)
+                                  (list (user-message-sxml error))
                                   '()))))
                    port)))))
             ((invalid-authorization-code? error)
@@ -145,8 +146,8 @@
                               (xml->sxml
                                (W_ (format #f "<p>The authorization code is forged, or expired.</p>")))
                               ((*TOP* ,p) p))
-                            ,@(if (message-for-the-user? error)
-                                  (user-message error)
+                            ,@(if (user-message? error)
+                                  (list (user-message-sxml error))
                                   '()))))
                    port)))))
             ;; Other bad request
@@ -172,8 +173,8 @@
                               (xml->sxml
                                (W_ (format #f "<p>The token request failed.</p>")))
                               ((*TOP* ,p) p))
-                            ,@(if (message-for-the-user? error)
-                                  (user-message error)
+                            ,@(if (user-message? error)
+                                  (list (user-message-sxml error))
                                   '()))))
                    port)))))))
        thunk))))
@@ -231,7 +232,7 @@
                   (make-exception
                    (make-unsupported-grant-type #f)
                    (make-exception-with-message final-message)
-                   (make-message-for-the-user final-user-message)))))
+                   (make-user-message final-user-message)))))
              (receive (webid client-id)
                  (case (string->symbol grant-type)
                    ((authorization_code)
@@ -249,7 +250,7 @@
                                   (make-exception
                                    (make-no-authorization-code)
                                    (make-exception-with-message final-message)
-                                   (make-message-for-the-user final-user-message)))))
+                                   (make-user-message final-user-message)))))
                              (with-exception-handler
                                  (lambda (error)
                                    (raise-exception
@@ -274,7 +275,7 @@
                            (make-exception
                             (make-no-refresh-token)
                             (make-exception-with-message final-message)
-                            (make-message-for-the-user final-user-message)))))
+                            (make-user-message final-user-message)))))
                       (refresh:with-refresh-token
                        refresh-token
                        (jwk dpop)
@@ -293,7 +294,7 @@
                        (make-exception
                         (make-unsupported-grant-type grant-type)
                         (make-exception-with-message final-message)
-                        (make-message-for-the-user final-user-message))))))
+                        (make-user-message final-user-message))))))
                (let ((id-token
                       (issue <id-token>
                              issuer-key