diff options
| -rw-r--r-- | guix-build-coordinator/agent.scm | 125 |
1 files changed, 76 insertions, 49 deletions
diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm index b89c1f8..dc44251 100644 --- a/guix-build-coordinator/agent.scm +++ b/guix-build-coordinator/agent.scm @@ -103,8 +103,10 @@ (write-textfile metrics-registry metrics-file))) + (define parallel-uploads + 3) (define upload-slots - (make-vector 3 #f)) + (make-vector parallel-uploads #f)) (define queued-uploads '()) @@ -161,7 +163,6 @@ (define (free-slot index) (with-mutex uploads-mutex - (peek "FREEING SLOT" index) (vector-set! upload-slots index #f)) @@ -189,8 +190,6 @@ free-index upload-progress-record) - (peek "USING SLOT" free-index) - (set! queued-uploads (delete file queued-uploads string=?)) @@ -218,7 +217,7 @@ (loop)))))) - (define (process-job build) + (define (process-job build perform-post-build-actions) (let ((build-id (assoc-ref build "uuid")) (derivation-name (or (assoc-ref build "derivation_name") (assoc-ref build "derivation-name"))) @@ -256,27 +255,30 @@ ;; TODO Check this handles timezones right (end-time (localtime (time-second (current-time)) "UTC"))) - (agent-submit-log-file lgr - coordinator-interface - build-id derivation-name) - - (if result - (post-build-success lgr - coordinator-interface - build-id - derivation-name - end-time - submit-outputs? - with-upload-slot) - (post-build-failure lgr - coordinator-interface - build-id - derivation-name - end-time))) - (log-msg lgr 'INFO - build-id - ": finished processing: " - derivation-name)) + (perform-post-build-actions + build + (lambda () + (agent-submit-log-file lgr + coordinator-interface + build-id derivation-name) + + (if result + (post-build-success lgr + coordinator-interface + build-id + derivation-name + end-time + submit-outputs? + with-upload-slot) + (post-build-failure lgr + coordinator-interface + build-id + derivation-name + end-time)) + (log-msg lgr 'INFO + build-id + ": finished processing: " + derivation-name))))) (begin (log-msg lgr 'INFO build-id @@ -300,32 +302,54 @@ (log-msg lgr 'INFO "starting agent " uuid) (log-msg lgr 'INFO "connecting to coordinator " (slot-ref coordinator-interface 'coordinator-uri)) - (let-values (((process-job-with-queue count-jobs count-threads list-jobs) - (create-work-queue current-max-builds - process-job - #:thread-start-delay - (make-time time-duration - 0 - (max 20 - (- 121 (* 100 + (let*-values (((perform-post-build-actions count-post-build-jobs + count-post-build-threads + list-post-build-jobs) + (create-work-queue #f ;; One thread per job + (lambda (build thunk) + (thunk)))) + + ((process-job-with-queue count-jobs count-threads list-jobs) + (create-work-queue current-max-builds + (lambda (build) + (process-job build + perform-post-build-actions)) + #:thread-start-delay + (make-time time-duration + 0 + (max 5 + (- 106(* 100 (/ 120 64)))))))) (define (display-info) (display (simple-format #f "current threads: ~A current jobs: ~A\n~A\n" (count-threads) - (count-jobs) - (string-join - (map (match-lambda - ((build-details) - (simple-format - #f " - ~A (priority: ~A) + (+ (count-jobs) (count-post-build-jobs)) + (string-append + (string-join + (map (match-lambda + ((build-details) + (simple-format + #f " - ~A (priority: ~A) + ~A" + (assoc-ref build-details "uuid") + (assoc-ref build-details "priority") + (assoc-ref build-details "derivation-name")))) + (list-jobs)) + "\n") + "\n" + (string-join + (map (match-lambda + ((build-details _) + (simple-format + #f " - ~A (priority: ~A) ~A" - (assoc-ref build-details "uuid") - (assoc-ref build-details "priority") - (assoc-ref build-details "derivation-name")))) - (list-jobs)) - "\n")) + (assoc-ref build-details "uuid") + (assoc-ref build-details "priority") + (assoc-ref build-details "derivation-name")))) + (list-post-build-jobs)) + "\n"))) (current-error-port))) (let ((details (submit-status coordinator-interface @@ -360,9 +384,12 @@ (if (or (< job-count current-threads) (= job-count 0)) (let* ((queued-build-ids - (map (lambda (job-args) - (assoc-ref (car job-args) "uuid")) - (list-jobs))) + (append + (map (lambda (job-args) + (assoc-ref (car job-args) "uuid")) + (append + (list-jobs) + (list-post-build-jobs))))) (fetched-builds (fetch-builds-for-agent coordinator-interface systems @@ -389,7 +416,7 @@ new-builds) (when (null? new-builds) - (sleep 30))) + (sleep 5))) (sleep 3))))))) (define* (build-log-procedure lgr #:optional build-id) |