diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-07-06 12:07:13 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-07-06 12:52:46 +0200 |
commit | 9d23792481d7ae8d75d9565dd2a0b1e17d08943b (patch) | |
tree | c7b9933c8d946175d480dc8e50b8ad86a527d704 /src/scm/webid-oidc | |
parent | 888fb3e55a5deca32aa46a2bdc7fa5994768797d (diff) |
Also log exceptions
Diffstat (limited to 'src/scm/webid-oidc')
-rw-r--r-- | src/scm/webid-oidc/program.scm | 44 | ||||
-rw-r--r-- | src/scm/webid-oidc/token-endpoint.scm | 27 |
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)))))))))) |