diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-07-06 10:39:29 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-07-06 10:39:29 +0200 |
commit | 30cc567b291c9f5af200a327bbd79f555541b57b (patch) | |
tree | 87272f8b7b7964496b19eb803bd7a54a84c69cbc /src/scm/webid-oidc | |
parent | c243694b33f1783824a4d4b747d1e463d500b2b4 (diff) |
Log the authenticated user too
Diffstat (limited to 'src/scm/webid-oidc')
-rw-r--r-- | src/scm/webid-oidc/program.scm | 37 | ||||
-rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 47 |
2 files changed, 58 insertions, 26 deletions
diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm index f083700..50f0da4 100644 --- a/src/scm/webid-oidc/program.scm +++ b/src/scm/webid-oidc/program.scm @@ -100,22 +100,39 @@ ((record-accessor &unknown-client-locale 'c-locale) error) (error->str error))) (lambda () - (receive (response response-body) - (handler request request-body) + (receive (response response-body user) + (call-with-values + (lambda () + (handler request request-body)) + (case-lambda + ((response response-body) + (values response response-body #f)) + ((response response-body user) + (values response response-body user)))) (let ((logging-port (let ((response-code (response-code response))) (if (>= response-code 400) ;; That’s an error (current-error-port) (current-output-port))))) - (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) - (response-reason-phrase response))) + (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) + (response-reason-phrase response)))) (return (build-response #:version (response-version response) diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index 9257a43..a8e88f5 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -120,12 +120,13 @@ (lambda () (f return)))))) -(define (serve-get return path if-match if-none-match content-type content etag headers) +(define (serve-get return path if-match if-none-match content-type content etag headers user) (define (respond-normal) (return (build-response #:headers headers) - content)) + content + user)) (if if-match ;; If the precondition failed, then we should respond with 412 (with-exception-handler @@ -136,7 +137,8 @@ (build-response #:code 412 #:reason-phrase "Precondition Failed") - #f)) + #f + user)) (lambda () (check-precondition path if-match if-none-match etag) (respond-normal))) @@ -151,7 +153,8 @@ #:code 304 #:reason-phrase "Not Modified" #:headers headers) - #f)) + #f + user)) (lambda () (when if-none-match (check-precondition path if-match if-none-match etag)) @@ -207,7 +210,8 @@ negociated-content (car (assq-ref headers 'etag)) (cons `(content-type ,negociated-content-type) - other-headers)))))) + other-headers) + user))))) ((PUT) (return (build-response @@ -220,7 +224,8 @@ request-body #:http-get http-get) . #f)))) - "")) + "" + user)) ((POST) (let ((types (map car @@ -239,7 +244,8 @@ (request-content-type request) request-body #:http-get http-get)))) - ""))) + "" + user))) ((DELETE) (delete server-uri owner user (uri-path (request-uri request)) @@ -248,7 +254,8 @@ #:http-get http-get) (return (build-response) - ""))))) + "" + user))))) (lambda (return error) (if (cannot-fetch-group? error) (format (current-error-port) (G_ "Warning: ~a\n") @@ -267,7 +274,8 @@ #:host (uri-host server-uri) #:port (uri-port server-uri) #:path (uri-slash-semantics-error-expected-path error))))) - #f)) + #f + user)) ((or (path-not-found? error) (auxiliary-resource-absent? error) (forbidden? error)) @@ -275,17 +283,20 @@ ;; That’s a forbidden (return (build-response #:code 403 #:reason-phrase "Forbidden") - #f) + #f + user) (return (build-response #:code 401 #:reason-phrase "Unauthorized" #:headers `((www-authenticate . ((DPoP))))) - #f))) + #f + user))) ((or (cannot-delete-root? error)) (return (build-response #:code 405 #:reason-phrase "Method Not Allowed") - #f)) + #f + user)) ((or (container-not-empty? error) (incorrect-containment-triples? error) (path-is-auxiliary? error)) @@ -293,24 +304,28 @@ (build-response #:code 409 #:reason-phrase "Conflict") - #f)) + #f + user)) ((unsupported-media-type? error) (return (build-response #:code 415 #:reason-phrase "Unsupported Media Type") - #f)) + #f + user)) ((precondition-failed? error) (return (build-response #:code 412 #:reason-phrase "Precondition Failed") - #f)) + #f + user)) ((not-acceptable? error) (return (build-response #:code 406 #:reason-phrase "Not Acceptable") - #f)) + #f + user)) (else (raise-exception error))))))))) |