Log the authenticated user too

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)))))))))