Improve agent logging

Use a logger, and set out different levels. Also try and neaten up the
formatting.

1 files changed, 109 insertions, 71 deletions

diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index 5f24b70..acb1572 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -22,12 +22,16 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (ice-9 futures)
   #:use-module (ice-9 atomic)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 exceptions)
   #:use-module (rnrs bytevectors)
   #:use-module (web http)
+  #:use-module (oop goops)
+  #:use-module (logging logger)
+  #:use-module (logging port-log)
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix base32)
@@ -40,53 +44,79 @@
                    max-parallel-builds
                    derivation-substitute-urls
                    non-derivation-substitute-urls)
+  (define lgr (make <logger>))
+  (define port-log (make <port-log>
+                     #:port (current-output-port)
+                     #:formatter
+                     (lambda (lvl time str)
+                       (format #f "~a (~5a): ~a~%"
+                               (strftime "%F %H:%M:%S" (localtime time))
+                               lvl
+                               str))))
+
+
   (define (fetch-jobs current-count max-count)
     (let ((received-builds
            (fetch-builds-for-agent coordinator-uri uuid password
                                    systems
                                    max-count)))
-      (simple-format #t "have ~A builds, max ~A builds, received ~A\n"
-                     current-count max-count (- (length received-builds)
-                                                current-count))
+      (log-msg lgr 'INFO
+               "have " current-count
+               " builds, max " max-count
+               " builds, received "
+               (- (length received-builds) current-count))
       received-builds))
 
   (define (process-job build)
     (let ((build-id (assoc-ref build "uuid"))
           (derivation-name (assoc-ref build "derivation-name")))
-      (simple-format #t "~A: setting up to build: ~A\n"
-                     build-id derivation-name)
+      (log-msg lgr 'INFO
+               build-id
+               ": setting up to build: "
+               derivation-name)
       (with-store store
         (let ((pre-build-status (pre-build-process
+                                 lgr
                                  store
+                                 build-id
                                  derivation-substitute-urls
                                  non-derivation-substitute-urls
                                  derivation-name)))
           (if (eq? (assq-ref pre-build-status 'result) 'success)
               (begin
-                (simple-format #t "~A: setup successful, building: ~A\n"
-                               build-id derivation-name)
+                (log-msg lgr 'INFO
+                         build-id
+                         ": setup successful, building: "
+                         derivation-name)
                 (report-build-start coordinator-uri uuid password
                                     build-id)
-                (let* ((result (perform-build store derivation-name))
+                (let* ((result (perform-build lgr store derivation-name))
                        ;; TODO Check this handles timezones right
                        (end-time (localtime (current-time) "UTC")))
 
-                  (agent-submit-log-file uuid coordinator-uri password
+                  (agent-submit-log-file lgr uuid coordinator-uri password
                                          build-id derivation-name)
 
                   ((if result
                        post-build-success
                        post-build-failure)
+                   lgr
                    uuid coordinator-uri password
                    build-id
                    derivation-name
                    end-time)))
               (begin
-                (simple-format #t "~A: failure: ~A\n" build-id pre-build-status)
+                (log-msg lgr 'INFO
+                         build-id
+                         ": setup failure: "
+                         (assq-ref pre-build-status 'failure_reason))
                 (report-setup-failure coordinator-uri uuid password
                                       build-id
                                       pre-build-status)))))))
 
+  (add-handler! lgr port-log)
+  (open-log! lgr)
+
   (let-values (((process-job-with-queue count-jobs)
                 (create-work-queue max-parallel-builds
                                    process-job)))
@@ -125,7 +155,7 @@
                   (sleep 3)
                   (loop build-ids)))))))))
 
-(define (agent-submit-log-file uuid coordinator-uri password
+(define (agent-submit-log-file lgr uuid coordinator-uri password
                                build-id derivation-name)
   (retry-on-error
    (lambda ()
@@ -136,8 +166,9 @@
            (simple-format #f "log file missing for ~A (~A)"
                           derivation-name build-id))))
 
-       (simple-format #t "~A: uploading log file ~A\n"
-                      build-id log-file)
+       (log-msg lgr 'INFO
+                build-id ": uploading log file "
+                log-file)
        (submit-log-file
         coordinator-uri uuid password
         build-id
@@ -145,11 +176,15 @@
    #:times 6
    #:delay 30))
 
-(define (pre-build-process store
+(define (pre-build-process lgr
+                           store
+                           build-id
                            derivation-substitute-urls
                            non-derivation-substitute-urls
                            derivation-name)
   (define (find-missing-inputs derivation inputs)
+    (log-msg lgr 'DEBUG
+             build-id ": checking the availability of build inputs")
     (let* ((output-paths
             (append-map derivation-input-output-paths inputs))
            (missing-paths
@@ -163,9 +198,9 @@
                                    non-derivation-substitute-urls))
 
               (unless non-derivation-substitute-urls
-                (simple-format
-                 #t
-                 "warning: unable to query substitute servers without caching\n"))
+                (log-msg lgr 'WARNING
+                         "non-derivation-substitute-urls unset,
+unable to query substitute servers without caching"))
 
               (map (lambda (file)
                      (and
@@ -178,9 +213,9 @@
                           (if (has-substitutes? store file)
                               #t
                               (begin
-                                (simple-format
-                                 #t "warning: a substitute should be available for ~A, but the daemon claims it's not\n"
-                                 file)
+                                (log-msg lgr 'WARNING
+                                         "a substitute should be available for " file ",
+but the guix-daemon claims it's unavailable")
                                 #f))))))
                    missing-paths))))
 
@@ -225,10 +260,9 @@
                   (if (null? missing-files)
                       '()
                       (begin
-                        (simple-format
-                         (current-error-port)
-                         "warning: failed to fetch substitutes for: ~A\n"
-                         missing-files)
+                        (log-msg lgr 'WARNING
+                                 "failed to fetch substitutes for "
+                                 missing-files)
 
                         (let ((unavailable-outputs
                                (delete-duplicates
@@ -240,15 +274,13 @@
                                     missing-output))
                                  missing-files))))
 
-                          (simple-format
-                           (current-error-port)
-                           "warning: the following outputs are missing:\n~A\n"
-                           (string-join
-                            (map (lambda (output)
-                                   (string-append
-                                    " - " output))
-                                 unavailable-outputs)
-                            "\n"))
+                          (log-msg lgr 'WARNING
+                                   "the following outputs are missing: "
+                                   (string-join
+                                    (map (lambda (output)
+                                           (string-append
+                                            " - " output))
+                                         unavailable-outputs)))
 
                           unavailable-outputs)))))))))
 
@@ -260,6 +292,10 @@
           (catch
             #t
             (lambda ()
+              (log-msg lgr 'DEBUG build-id ": deleting "
+                       (if (eq? (length output-file-names) 1)
+                           "output"
+                           "outputs"))
               ;; There can be issues deleting links when collecting garbage
               ;; from multiple threads
               (monitor
@@ -267,9 +303,9 @@
                  (delete-paths store output-file-names)))
               #t)
             (lambda (key args)
-              (simple-format (current-error-port)
-                             "error: delete-outputs: ~A ~A\n"
-                             key args)
+              (log-msg lgr 'ERROR
+                       "delete-outputs: "
+                       key args)
               #f))
           #t)))
 
@@ -279,12 +315,13 @@
              (and
               (with-exception-handler
                   (lambda (exn)
-                    (simple-format
-                     (current-error-port)
-                     "error: exception when reading/fetching derivation: ~A\n"
-                     exn)
+                    (log-msg lgr 'ERROR
+                             "exception when reading/fetching derivation: "
+                             exn)
                     #f)
                 (lambda ()
+                  (log-msg lgr 'DEBUG
+                           build-id ": substituting derivation")
                   (retry-on-error
                    (lambda ()
                      (substitute-derivation derivation-name
@@ -296,22 +333,25 @@
                 #:unwind? #t)
               (read-derivation-from-file derivation-name)))))
     (if derivation
-        (match (delete-outputs derivation)
-          (#t
-           (let ((missing-inputs
-                  (find-missing-inputs derivation (derivation-inputs derivation))))
-             (if (null? missing-inputs)
-                 '((result . success))
-                 `((result         . failure)
-                   (failure_reason . missing_inputs)
-                   (missing_inputs . ,(list->vector missing-inputs))))))
-          (failure
-           '((result         . failure)
-             (failure_reason . could_not_delete_outputs))))
+        (begin
+          (log-msg lgr 'DEBUG
+                   build-id ": derivation read from file")
+          (match (delete-outputs derivation)
+            (#t
+             (let ((missing-inputs
+                    (find-missing-inputs derivation (derivation-inputs derivation))))
+               (if (null? missing-inputs)
+                   '((result . success))
+                   `((result         . failure)
+                     (failure_reason . missing_inputs)
+                     (missing_inputs . ,(list->vector missing-inputs))))))
+            (failure
+             '((result         . failure)
+               (failure_reason . could_not_delete_outputs)))))
         '((result         . failure)
           (failure_reason . error_fetching_derivation)))))
 
-(define (perform-build store derivation-name)
+(define (perform-build lgr store derivation-name)
   (set-build-options store
                      #:use-substitutes? #f)
 
@@ -321,16 +361,14 @@
         (build-things store (list derivation-name))
         #t)
       (lambda (key . args)
-        (simple-format (current-error-port)
-                       "error: build: ~A ~A\n"
-                       key args)
+        (log-msg lgr 'ERROR
+                 "build: " key " " args)
 
         #f))))
 
-(define (post-build-failure uuid coordinator-uri password
+(define (post-build-failure lgr uuid coordinator-uri password
                             build-id derivation end-time)
-  (simple-format #t "build ~A failed, reporting to coordinator\n"
-                 build-id)
+  (log-msg lgr 'INFO build-id ": build failed")
   (with-exception-handler
       (lambda (exn)
         (unless (agent-error-from-coordinator? exn)
@@ -341,8 +379,8 @@
           (if (string? details)
               (cond
                ((string=? details "build_already_processed")
-                (simple-format
-                 #t "warning: coordinator indicates this build is already marked as processed\n")
+                (log-msg lgr 'WARNING
+                         build-id ": coordinator indicates this build is already marked as processed")
                 #t)
                (else
                 (raise-exception
@@ -364,7 +402,7 @@
                              (end_time . ,(strftime "%F %T" end-time)))))
     #:unwind? #t))
 
-(define (post-build-success uuid coordinator-uri password
+(define (post-build-success lgr uuid coordinator-uri password
                             build-id derivation end-time)
   (define output-details
     (map
@@ -395,12 +433,12 @@
           (if (string? details)
               (cond
                ((string=? details "build_already_processed")
-                (simple-format
-                 #t "warning: coordinator indicates this build is already marked as processed\n")
+                (log-msg lgr 'WARNING
+                         build-id ": coordinator indicates this build is already marked as processed")
                 #t)
                ((string=? details "missing_build_log_file")
                 ;; Retry submitting the log file
-                (agent-submit-log-file uuid coordinator-uri password
+                (agent-submit-log-file lgr uuid coordinator-uri password
                                        build-id derivation)
 
                 (attempt-submit-build-result))
@@ -449,19 +487,19 @@
       #:unwind? #t))
 
   (define (submit-one-output output-name output)
-    (simple-format #t "submitting output ~A\n"
-                   (derivation-output-path output))
+    (log-msg lgr 'INFO
+             build-id ": submitting output "
+             (derivation-output-path output))
     (submit-output coordinator-uri uuid password
                    build-id output-name
                    (derivation-output-path output)))
 
-  (simple-format #t "build ~A successful, reporting to coordinator\n"
-                 build-id)
-
+  (log-msg lgr 'INFO build-id ": build successful, submitting outputs")
   (for-each (match-lambda
               ((output-name . output)
                (submit-one-output output-name output)))
             (derivation-outputs (read-derivation-from-file derivation)))
 
-  (simple-format #t "finished submitting outputs, reporting result\n")
+  (log-msg lgr 'INFO
+           build-id ": finished submitting outputs, reporting build success")
   (attempt-submit-build-result))