Improve the logging from the agent -> coordinator communication

2 files changed, 85 insertions, 45 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 25fa28c..80d451a 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -29,6 +29,7 @@
   #:use-module (ice-9 binary-ports)
   #:use-module (system repl error-handling)
   #:use-module (rnrs bytevectors)
+  #:use-module (logging logger)
   #:use-module (json)
   #:use-module (web http)
   #:use-module (web client)
@@ -79,12 +80,15 @@
 (define (with-request-mutex thunk)
   (monitor (thunk)))
 
-(define* (coordinator-handle-failed-request method path response body
+(define (default-log level . components)
+  (apply log-msg level components))
+
+(define* (coordinator-handle-failed-request log method path response body
                                             #:key first-request-failed?)
-  (simple-format
-   (current-error-port)
-   "error: coordinator-http-request: ~A ~A: ~A\n"
-   method path (response-code response))
+  (log 'ERROR
+       "coordinator-http-request: "
+       method path " "
+       (response-code response))
 
   (catch #t
     (lambda ()
@@ -93,13 +97,12 @@
           (json-string->scm (utf8->string body))
           (utf8->string body)))
     (lambda (key . args)
-      (simple-format
-       (current-error-port)
-       "error decoding body ~A ~A\n"
-       key args)
+      (log 'ERROR
+           "error decoding body " key " " args)
       #f)))
 
-(define* (coordinator-http-request coordinator-uri agent-uuid password
+(define* (coordinator-http-request log
+                                   coordinator-uri agent-uuid password
                                    path
                                    #:key method body (headers '())
                                    succeed-on-access-denied-retry?)
@@ -130,7 +133,8 @@
       (let ((code (response-code response)))
         (cond
          ((eq? code 400)
-          (and=> (coordinator-handle-failed-request method
+          (and=> (coordinator-handle-failed-request log
+                                                    method
                                                     path
                                                     response
                                                     body)
@@ -141,7 +145,8 @@
 
          ((>= (response-code response) 400)
           (let ((body
-                 (coordinator-handle-failed-request method
+                 (coordinator-handle-failed-request log
+                                                    method
                                                     path
                                                     response
                                                     body)))
@@ -150,9 +155,8 @@
                      (equal? body
                              '(("error" . "access denied"))))
                 (begin
-                  (simple-format
-                   (current-error-port)
-                   "warning: treating access denied response as success\n")
+                  (log 'WARNING
+                       "treating access denied response as success")
                   (values body response))
                 (begin
                   (set! first-request-failed? #t)
@@ -169,16 +173,19 @@
                   #:delay 10
                   #:ignore agent-error-from-coordinator?))
 
-(define (submit-status coordinator-uri agent-uuid password
-                       status)
+(define* (submit-status coordinator-uri agent-uuid password
+                        status
+                        #:key (log default-log))
   (coordinator-http-request
+   log
    coordinator-uri agent-uuid password
    (string-append "/agent/" agent-uuid)
    #:method 'PUT                        ; TODO Should be PATCH
    #:body `((status . ,status))))
 
-(define (submit-output coordinator-uri agent-uuid password
-                       build-id output-name file)
+(define* (submit-output coordinator-uri agent-uuid password
+                        build-id output-name file
+                        #:key (log default-log))
   (define auth-value
     (string-append
      "Basic "
@@ -218,15 +225,14 @@
              (template  (string-append directory
                                        "/guix-build-coordinator-file.XXXXXX"))
              (out       (mkstemp! template)))
-        (simple-format #t "compressing ~A -> ~A prior to sending\n"
-                       file template)
+        (log 'INFO "compressing " file " -> " template " prior to sending")
         (call-with-lzip-output-port out
           (lambda (port)
             (write-file file port))
           #:level 9)
         (close-port out)
 
-        (simple-format #t "finished compressing ~A, now sending\n" file)
+        (log 'INFO "finished compressing " file ", now sending")
         (retry-on-error
          (lambda ()
            (with-request-mutex
@@ -238,14 +244,15 @@
                                  uri
                                  (lambda (port)
                                    (with-time-logging
-                                    (simple-format #f "sending ~A" file)
+                                    (log 'INFO "sending " file)
                                     (dump-port file-port port
                                                #:buffer-size (expt 2 20))))
                                  #:headers `((Authorization . ,auth-value)))))
                     (when (>= (response-code response) 400)
                       (raise-exception
                        (make-exception-with-message
-                        (coordinator-handle-failed-request 'PUT
+                        (coordinator-handle-failed-request log
+                                                           'PUT
                                                            (uri-path uri)
                                                            response
                                                            body))))))))))
@@ -254,8 +261,9 @@
 
         (delete-file template))))
 
-(define (submit-log-file coordinator-uri agent-uuid password
-                         build-id file)
+(define* (submit-log-file coordinator-uri agent-uuid password
+                          build-id file
+                          #:key (log default-log))
   (define auth-value
     (string-append
      "Basic "
@@ -291,36 +299,44 @@
           (if (>= (response-code response) 400)
               (raise-exception
                (make-exception-with-message
-                (coordinator-handle-failed-request 'PUT
+                (coordinator-handle-failed-request log
+                                                   'PUT
                                                    (uri-path uri)
                                                    response
                                                    body)))
               (begin
-                (simple-format #t "~A: successfully uploaded log file (~A)\n"
-                               build-id
-                               (response-code response))
+                (log 'INFO
+                     "successfully uploaded log file ("
+                     (response-code response)
+                     ")")
                 #t))))))
    #:times 9
    #:delay (+ 30 (random 60))))
 
-(define (submit-build-result coordinator-uri agent-uuid password
-                             build-id result)
+(define* (submit-build-result coordinator-uri agent-uuid password
+                              build-id result
+                              #:key (log default-log))
   (coordinator-http-request
+   log
    coordinator-uri agent-uuid password
    (string-append "/build/" build-id)
    #:method 'PUT                        ; TODO Should be PATCH
    #:body result))
 
-(define (report-build-start coordinator-uri agent-uuid password
-                            build-id)
+(define* (report-build-start coordinator-uri agent-uuid password
+                             build-id
+                             #:key (log default-log))
   (coordinator-http-request
+   log
    coordinator-uri agent-uuid password
    (string-append "/build/" build-id "/report-build-start")
    #:method 'POST))
 
-(define (report-setup-failure coordinator-uri agent-uuid password
-                              build-id report)
+(define* (report-setup-failure coordinator-uri agent-uuid password
+                               build-id report
+                               #:key (log default-log))
   (coordinator-http-request
+   log
    coordinator-uri agent-uuid password
    (string-append "/build/" build-id "/report-setup-failure")
    #:method 'POST
@@ -329,9 +345,11 @@
 
 (define* (fetch-builds-for-agent coordinator-uri agent-uuid password
                                  systems
-                                 target-count)
+                                 target-count
+                                 #:key (log default-log))
   (vector->list
    (assoc-ref (coordinator-http-request
+               log
                coordinator-uri agent-uuid password
                (string-append "/agent/" agent-uuid "/fetch-builds")
                #:body `((target_count . ,target-count)
diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index b5180e2..656cfc3 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -59,7 +59,8 @@
     (let ((received-builds
            (fetch-builds-for-agent coordinator-uri uuid password
                                    systems
-                                   max-count)))
+                                   max-count
+                                   #:log (build-log-procedure lgr))))
       (log-msg lgr 'INFO
                "have " current-count
                " builds, max " max-count
@@ -89,7 +90,8 @@
                          ": setup successful, building: "
                          derivation-name)
                 (report-build-start coordinator-uri uuid password
-                                    build-id)
+                                    build-id
+                                    #:log (build-log-procedure lgr build-id))
                 (let* ((result (perform-build lgr store build-id derivation-name))
                        ;; TODO Check this handles timezones right
                        (end-time (localtime (current-time) "UTC")))
@@ -112,7 +114,9 @@
                          (assq-ref pre-build-status 'failure_reason))
                 (report-setup-failure coordinator-uri uuid password
                                       build-id
-                                      pre-build-status)))))))
+                                      pre-build-status
+                                      #:log (build-log-procedure lgr
+                                                                 build-id))))))))
 
   (add-handler! lgr port-log)
   (open-log! lgr)
@@ -120,7 +124,9 @@
   (let-values (((process-job-with-queue count-jobs)
                 (create-work-queue max-parallel-builds
                                    process-job)))
-    (let ((details (submit-status coordinator-uri uuid password 'idle)))
+    (let ((details (submit-status coordinator-uri uuid password 'idle
+                                  #:log (build-log-procedure
+                                         (assoc-ref build "uuid")))))
       (let* ((builds (vector->list (assoc-ref details "builds")))
              (initial-build-ids (map (lambda (build)
                                        (assoc-ref build "uuid"))
@@ -155,6 +161,18 @@
                   (sleep 3)
                   (loop build-ids)))))))))
 
+(define* (build-log-procedure lgr #:optional build-id)
+  (lambda (level . components)
+    (apply log-msg
+           lgr
+           level
+           (if build-id
+               (cons*
+                build-id
+                ": "
+                components)
+               components))))
+
 (define (agent-submit-log-file lgr uuid coordinator-uri password
                                build-id derivation-name)
   (retry-on-error
@@ -172,7 +190,8 @@
        (submit-log-file
         coordinator-uri uuid password
         build-id
-        log-file)))
+        log-file
+        #:log (build-log-procedure lgr build-id))))
    #:times 6
    #:delay 30))
 
@@ -402,7 +421,8 @@ but the guix-daemon claims it's unavailable")
       (submit-build-result coordinator-uri uuid password
                            build-id
                            `((result   . failure)
-                             (end_time . ,(strftime "%F %T" end-time)))))
+                             (end_time . ,(strftime "%F %T" end-time)))
+                           #:log (build-log-procedure lgr build-id)))
     #:unwind? #t))
 
 (define (post-build-success lgr uuid coordinator-uri password
@@ -486,7 +506,8 @@ but the guix-daemon claims it's unavailable")
          coordinator-uri uuid password build-id
          `((result   . success)
            (end_time . ,(strftime "%F %T" end-time))
-           (outputs  . ,(list->vector output-details)))))
+           (outputs  . ,(list->vector output-details)))
+         #:log (build-log-procedure lgr build-id)))
       #:unwind? #t))
 
   (define (submit-one-output output-name output)
@@ -495,7 +516,8 @@ but the guix-daemon claims it's unavailable")
              (derivation-output-path output))
     (submit-output coordinator-uri uuid password
                    build-id output-name
-                   (derivation-output-path output)))
+                   (derivation-output-path output)
+                   #:log (build-log-procedure lgr build-id)))
 
   (log-msg lgr 'INFO build-id ": build successful, submitting outputs")
   (for-each (match-lambda