Also log exceptions

2 files changed, 41 insertions, 30 deletions

diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm
index 3ee86d8..be72f75 100644
--- a/src/scm/webid-oidc/program.scm
+++ b/src/scm/webid-oidc/program.scm
@@ -103,38 +103,42 @@
                          ((record-accessor &unknown-client-locale 'c-locale) error)
                          (error->str error)))
              (lambda ()
-               (receive (response response-body user)
+               (receive (response response-body user cause)
                    (call-with-values
                        (lambda ()
                          (handler request request-body))
                      (case-lambda
                        ((response response-body)
-                        (values response response-body #f))
+                        (values response response-body #f #f))
                        ((response response-body user)
-                        (values response response-body user))))
+                        (values response response-body user #f))
+                       ((response response-body user cause)
+                        (values response response-body user cause))))
                  (let ((logging-port
                         (let ((response-code (response-code response)))
                           (if (>= response-code 400)
                               ;; That’s an error
                               (current-error-port)
                               (current-output-port)))))
-                   (if user
-                       (format logging-port
-                               (G_ "~a: ~a (~a): ~s ~a ~s ~a\n")
-                               (date->string (time-utc->date (current-time)))
-                               (uri->string user)
-                               (request-ip-address request)
-                               (request-method request)
-                               (uri-path (request-uri request))
-                               (response-code response)
-                               (response-reason-phrase response))
-                       (format logging-port
-                               (G_ "~a: ~a: ~s ~a ~s ~a\n")
-                               (date->string (time-utc->date (current-time)))
-                               (request-ip-address request)
-                               (request-method request)
-                               (uri-path (request-uri request))
-                               (response-code response)
+                   (format logging-port
+                           (G_ "~a: ~s ~a ~s ~a\n")
+                           (if user
+                               (format #f (G_ "~a: ~a (~a)")
+                                       (date->string (time-utc->date (current-time)))
+                                       (uri->string user)
+                                       (request-ip-address request))
+                               (format #f (G_ "~a: ~a")
+                                       (date->string (time-utc->date (current-time)))
+                                       (request-ip-address request)))
+                           (request-method request)
+                           (uri-path (request-uri request))
+                           (response-code response)
+                           (if cause
+                               (string-append
+                                (response-reason-phrase response)
+                                " "
+                                (format #f (G_ "(there was an error: ~a)")
+                                        (error->str cause)))
                                (response-reason-phrase response))))
                  (return
                   (build-response
diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm
index 95681bb..5a05945 100644
--- a/src/scm/webid-oidc/token-endpoint.scm
+++ b/src/scm/webid-oidc/token-endpoint.scm
@@ -30,6 +30,7 @@
   #:use-module (web uri)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 control)
   #:use-module (srfi srfi-19)
   #:use-module (rnrs bytevectors))
 
@@ -61,15 +62,19 @@
             (else
              (raise-exception err))))
         (throw err)))
-  (with-exception-handler
-      (lambda (error)
-        (values
-         (build-response
-          #:code 400
-          #:reason-phrase (string-append "Bad Request: " (error->str error)))
-         (error->str error)))
-    thunk
-    #:unwind? #t))
+  (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))))
 
 (define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity jti-list
                                      #:key
@@ -181,4 +186,6 @@
                      (access_token . ,access-token)
                      (token_type . "DPoP")
                      (expires_in . ,validity)
-                     (refresh_token . ,refresh-token)))))))))))))
+                     (refresh_token . ,refresh-token)))
+                  client-id
+                  #f))))))))))