Switch to a more sensible error reporting system

1 files changed, 200 insertions, 53 deletions

diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm
index 7c4d41c..30a78d4 100644
--- a/src/scm/webid-oidc/token-endpoint.scm
+++ b/src/scm/webid-oidc/token-endpoint.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
@@ -22,6 +22,7 @@
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc oidc-id-token)
   #:use-module (webid-oidc access-token)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
@@ -32,58 +33,158 @@
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 control)
+  #:use-module (ice-9 exceptions)
   #:use-module (srfi srfi-19)
-  #:use-module (rnrs bytevectors))
+  #:use-module (rnrs bytevectors)
+  #:use-module (sxml simple)
+  #:use-module (sxml match)
+  #:declarative? #t
+  #:export
+  (
+   &unsupported-grant-type
+   make-unsupported-grant-type
+   unsupported-grant-type?
+   unsupported-grant-type-grant-type
+
+   &no-authorization-code
+   make-no-authorization-code
+   no-authorization-code?
+
+   &no-refresh-token
+   make-no-refresh-token
+   no-refresh-token?
+
+   make-token-endpoint
+   ))
+
+(define-exception-type
+  &unsupported-grant-type
+  &external-error
+  make-unsupported-grant-type
+  unsupported-grant-type?
+  (grant-type unsupported-grant-type-grant-type))
+
+(define-exception-type
+  &no-authorization-code
+  &external-error
+  make-no-authorization-code
+  no-authorization-code?)
+
+(define-exception-type
+  &no-refresh-token
+  &external-error
+  make-no-refresh-token
+  no-refresh-token?)
 
 (define (try-handle-web-failure thunk)
-  (define (error->str err)
-    (if (record? err)
-        (let* ((type (record-type-descriptor err))
-               (get
-                (lambda (slot)
-                  ((record-accessor type slot) err)))
-               (recurse
-                (lambda (err)
-                  (error->str err))))
-          (case (record-type-name type)
-            ((&cannot-decode-dpop-proof)
-             (format #f "the DPoP proof is invalid"))
-            ((&no-authorization-code)
-             (format #f "there is no authorization code in the request"))
-            ((&no-refresh-token)
-             (format #f "there is no refresh token in the request"))
-            ((&cannot-decode-authorization-code)
-             (format #f "the authorization code is invalid"))
-            ((&invalid-refresh-token)
-             (format #f "the refresh token is invalid"))
-            ((&invalid-key-for-refresh-token)
-             (format #f "the refresh token is bound to another key"))
-            ((&unsupported-grant-type)
-             (format #f "the grant type ~s is not supported" (get 'value)))
-            (else
-             (raise-exception err))))
-        (throw err)))
   (call/ec
    (lambda (return)
      (with-exception-handler
          (lambda (error)
-           (return
-            (build-response
-             #:code 400
-             #:reason-phrase (string-append "Bad Request: " (error->str error)))
-            (error->str error)
-            #f
-            error))
-       thunk
-       #:unwind? #t))))
+           (unless (or (unsupported-grant-type? error)
+                       (no-authorization-code? error)
+                       (no-refresh-token? error)
+                       (refresh:invalid-refresh-token? error)
+                       (invalid-authorization-code? error))
+             (let ((final-message
+                    (if (exception-with-message? error)
+                        (format #f (G_ "while handling web failure for the token endpoint: ~a")
+                                (exception-message error))
+                        (format #f (G_ "an error happened during the token endpoint failure handling")))))
+               (raise-exception
+                (make-exception
+                 (make-exception-with-message final-message)
+                 error))))
+           (cond
+            ((refresh:invalid-refresh-token? error)
+             (return
+              (build-response
+               #:code 403
+               #:reason-phrase (G_ "reason-phrase|Forbidden")
+               #:headers '((content-type application/xhtml-xml)))
+              (call-with-output-string
+                (lambda (port)
+                  (sxml->xml
+                   `(*TOP*
+                     (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                     (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                              (xml:lang ,(W_ "xml-lang|en")))
+                           (body
+                            ,(sxml-match
+                              (xml->sxml
+                               (W_ (format #f "<h1>Invalid refresh token</h1>")))
+                              ((*TOP* ,title) title))
+                            ,(sxml-match
+                              (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)
+                                  '()))))
+                   port)))))
+            ((invalid-authorization-code? error)
+             (return
+              (build-response
+               #:code 400
+               #:reason-phrase (G_ "reason-phrase|Bad Request")
+               #:headers '((content-type application/xhtml-xml)))
+              (call-with-output-string
+                (lambda (port)
+                  (sxml->xml
+                   `(*TOP*
+                     (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                     (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                              (xml:lang ,(W_ "xml-lang|en")))
+                           (body
+                            ,(sxml-match
+                              (xml->sxml
+                               (W_ (format #f "<h1>Invalid authorization code</h1>")))
+                              ((*TOP* ,title) title))
+                            ,(sxml-match
+                              (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)
+                                  '()))))
+                   port)))))
+            ;; Other bad request
+            (else
+             (return
+              (build-response
+               #:code 400
+               #:reason-phrase (G_ "reason-phrase|Bad Request")
+               #:headers '((content-type application/xhtml+xml)))
+              (call-with-output-string
+                (lambda (port)
+                  (sxml->xml
+                   `(*TOP*
+                     (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                     (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                              (xml:lang ,(W_ "xml-lang|en")))
+                           (body
+                            ,(sxml-match
+                              (xml->sxml
+                               (W_ (format #f "<h1>Bad token request</h1>")))
+                              ((*TOP* ,title) title))
+                            ,(sxml-match
+                              (xml->sxml
+                               (W_ (format #f "<p>The token request failed.</p>")))
+                              ((*TOP* ,p) p))
+                            ,@(if (message-for-the-user? error)
+                                  (user-message error)
+                                  '()))))
+                   port)))))))
+       thunk))))
 
-(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity)
-  (lambda* (request request-body)
+(define (make-token-endpoint token-endpoint-uri iss alg jwk validity)
+  (lambda (request request-body)
+    (when (bytevector? request-body)
+      (set! request-body (utf8->string request-body)))
     (try-handle-web-failure
      (lambda ()
-       (when (bytevector? request-body)
-         (set! request-body (utf8->string request-body)))
-       (parameterize ((p:current-date ((p:current-date))))
+       (parameterize ((p:current-date ((p:current-date)))
+                      (web-locale request))
          (let ((current-time ((p:current-date))) ;; thunk parameter
                (form-args
                 (if (and (request-content-type request)
@@ -117,47 +218,93 @@
                         (assq-ref (request-headers request) 'dpop)
                         (lambda (jkt) #t))))
              (unless (and grant-type (string? grant-type))
-               (raise-unsupported-grant-type #f))
+               (let ((final-message 
+                      (format #f (G_ "missing grant type")))
+                     (final-user-message
+                      (sxml-match
+                       (xml->sxml
+                        (format #f (W_ "<p>You did not specify a grant_type for this request.</p>")))
+                       ((*TOP* ,p) p))))
+                 (raise-exception
+                  (make-exception
+                   (make-unsupported-grant-type #f)
+                   (make-exception-with-message final-message)
+                   (make-message-for-the-user final-user-message)))))
              (receive (webid client-id)
                  (case (string->symbol grant-type)
                    ((authorization_code)
                     (let ((code
                            (let ((str (assoc-ref form-args "code")))
                              (unless str
-                               (raise-no-authorization-code))
+                               (let ((final-message
+                                      (format #f (G_ "missing authorization code")))
+                                     (final-user-message
+                                      (sxml-match
+                                       (xml->sxml
+                                        (format #f (W_ "<p>You want to grant an authorization code, but you did not set one.</p>")))
+                                       ((*TOP* ,p) p))))
+                                 (raise-exception
+                                  (make-exception
+                                   (make-no-authorization-code)
+                                   (make-exception-with-message final-message)
+                                   (make-message-for-the-user final-user-message)))))
                              (authorization-code-decode str jwk))))
                       (values (authorization-code-webid code)
                               (authorization-code-client-id code))))
                    ((refresh_token)
                     (let ((refresh-token (assoc-ref form-args "refresh_token")))
                       (unless refresh-token
-                        (raise-no-refresh-token))
+                        (let ((final-message
+                               (format #f (G_ "missing refresh token")))
+                              (final-user-message
+                               (sxml-match
+                                (xml->sxml
+                                 (format #f (W_ "<p>You want to grant a refresh token, but you did not set one.</p>")))
+                                ((*TOP* ,p) p))))
+                          (raise-exception
+                           (make-exception
+                            (make-no-refresh-token)
+                            (make-exception-with-message final-message)
+                            (make-message-for-the-user final-user-message)))))
                       (refresh:with-refresh-token
                        refresh-token
                        (dpop-proof-jwk dpop)
                        values)))
                    (else
-                    (raise-unsupported-grant-type grant-type)))
+                    (let ((final-message
+                           (format #f (G_ "unsupported grant type: ~s")
+                                   grant-type))
+                          (final-user-message
+                           (sxml-match
+                            (xml->sxml
+                             (format #f (W_ "<p>You want to use <pre>~s</pre> as a grant type, but this is not supported.</p>")
+                                     grant-type))
+                            ((*TOP* ,p) p))))                       
+                      (raise-exception
+                       (make-exception
+                        (make-unsupported-grant-type grant-type)
+                        (make-exception-with-message final-message)
+                        (make-message-for-the-user final-user-message))))))
                (let* ((iat (time-second (date->time-utc current-time)))
                       (exp (+ iat validity)))
                  (let ((id-token
                         (issue-id-token
                          jwk
                          #:alg alg
-                         #:webid (uri->string webid)
+                         #:webid webid
                          #:sub (uri->string webid)
-                         #:iss (uri->string iss)
-                         #:aud (uri->string client-id)
+                         #:iss iss
+                         #:aud client-id
                          #:validity 3600))
                        (access-token
                         (issue-access-token
                          jwk
                          #:alg alg
-                         #:webid (uri->string webid)
-                         #:iss (uri->string iss)
+                         #:webid webid
+                         #:iss iss
                          #:validity 3600
                          #:client-key (dpop-proof-jwk dpop)
-                         #:client-id (uri->string client-id)))
+                         #:client-id client-id))
                        (refresh-token
                         (if (equal? grant-type "refresh_token")
                             (assoc-ref form-args "refresh_token")