diff options
Diffstat (limited to 'guix-build-coordinator/agent.scm')
-rw-r--r-- | guix-build-coordinator/agent.scm | 127 |
1 files changed, 97 insertions, 30 deletions
diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm index 747c6b1..4951ba6 100644 --- a/guix-build-coordinator/agent.scm +++ b/guix-build-coordinator/agent.scm @@ -269,35 +269,102 @@ (define (post-build-success uuid coordinator-uri password build-id derivation end-time) + (define output-details + (map + (match-lambda + ((output-name . output) + (let ((path-info (with-store store + (query-path-info + store + (derivation-output-path output))))) + `((name . ,output-name) + (hash . ,(bytevector->nix-base32-string + (path-info-hash path-info))) + (size . ,(path-info-nar-size path-info)) + (references . ,(list->vector + (map basename + (path-info-references path-info)))))))) + + (derivation-outputs (read-derivation-from-file derivation)))) + + (define (attempt-submit-build-result) + (with-exception-handler + (lambda (exn) + (unless (agent-error-from-coordinator? exn) + (raise-exception exn)) + + (let ((details + (agent-error-from-coordinator-details exn))) + (if (string? details) + (cond + ((string=? details "build_already_processed") + (simple-format + #t "warning: coordinator indicates this build is already marked as processed\n") + #t) + ((string=? details "missing_build_log_file") + ;; Retry submitting the log file + (agent-submit-log-file uuid coordinator-uri password + build-id derivation) + + (attempt-submit-build-result)) + (else + (raise-exception + (make-exception + (make-exception-with-message + "unrecognised error from coordinator") + (make-exception-with-irritants + details))))) + (or + (and=> (assoc-ref details "missing_output") + (lambda (missing-output-name) + (let ((missing-output + (any (match-lambda + ((name . output) + (if (string=? name missing-output-name) + output + #f))) + (derivation-outputs + (read-derivation-from-file derivation))))) + (unless missing-output + (raise-exception + (make-exception + (make-exception-with-message + "unknown missing output") + (make-exception-with-irritants + missing-output-name)))) + + (submit-one-output missing-output-name + missing-output)) + + (attempt-submit-build-result))) + (raise-exception + (make-exception + (make-exception-with-message + "unrecognised error from coordinator") + (make-exception-with-irritants + details))))))) + (lambda () + (submit-build-result + coordinator-uri uuid password build-id + `((result . success) + (end_time . ,(strftime "%F %T" end-time)) + (outputs . ,(list->vector output-details))))) + #:unwind? #t)) + + (define (submit-one-output output-name output) + (simple-format #t "submitting output ~A\n" + (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) - (let ((output-details - (map - (match-lambda - ((output-name . output) - (simple-format #t "submitting output ~A\n" - (derivation-output-path output)) - (submit-output coordinator-uri uuid password - build-id output-name - (derivation-output-path output)) - - (let ((path-info (with-store store - (query-path-info - store - (derivation-output-path output))))) - `((name . ,output-name) - (hash . ,(bytevector->nix-base32-string - (path-info-hash path-info))) - (size . ,(path-info-nar-size path-info)) - (references . ,(list->vector - (map basename - (path-info-references path-info)))))))) - - (derivation-outputs (read-derivation-from-file derivation))))) - - (simple-format #t "finished submitting outputs, reporting result\n") - (submit-build-result - coordinator-uri uuid password build-id - `((result . success) - (end_time . ,(strftime "%F %T" end-time)) - (outputs . ,(list->vector output-details)))))) + + (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") + (attempt-submit-build-result)) |