diff options
author | Christopher Baines <mail@cbaines.net> | 2020-11-30 19:07:28 +0000 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2020-11-30 19:14:30 +0000 |
commit | 437a6c5791a98e538bd9f9c876a63e4bf59b5aa1 (patch) | |
tree | 84b87312685487749e9a2a21a6b80c559d93dfd2 /guix-build-coordinator | |
parent | d5affc7addf66cb3115f60dad44faf49b067306b (diff) | |
download | build-coordinator-437a6c5791a98e538bd9f9c876a63e4bf59b5aa1.tar build-coordinator-437a6c5791a98e538bd9f9c876a63e4bf59b5aa1.tar.gz |
Improve the logging from the agent -> coordinator communication
Diffstat (limited to 'guix-build-coordinator')
-rw-r--r-- | guix-build-coordinator/agent-messaging/http.scm | 92 | ||||
-rw-r--r-- | guix-build-coordinator/agent.scm | 38 |
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 |