diff options
Diffstat (limited to 'guix-data-service/jobs.scm')
| -rw-r--r-- | guix-data-service/jobs.scm | 59 |
1 files changed, 46 insertions, 13 deletions
diff --git a/guix-data-service/jobs.scm b/guix-data-service/jobs.scm index 7d62be3..3ea1ebf 100644 --- a/guix-data-service/jobs.scm +++ b/guix-data-service/jobs.scm @@ -30,6 +30,8 @@ count-log-parts combine-log-parts! + guix-revision-id-for-job + process-jobs default-max-processes)) @@ -124,13 +126,33 @@ guix-data-service: error: missing log line: ~A (with-time-logging "vacuuming log parts" (vacuum-log-parts-table conn))) +(define (guix-revision-id-for-job conn job-id) + (match (exec-query + conn + " +SELECT guix_revisions.id +FROM guix_revisions +INNER JOIN load_new_guix_revision_jobs + ON guix_revisions.git_repository_id = load_new_guix_revision_jobs.git_repository_id + AND guix_revisions.commit = load_new_guix_revision_jobs.commit +WHERE load_new_guix_revision_jobs.id = $1" + (list (simple-format #f "~A" job-id))) + (((id)) id))) + (define* (process-jobs conn #:key max-processes latest-branch-revision-max-processes skip-system-tests? - per-job-parallelism) + extra-inferior-environment-variables + per-job-parallelism + ignore-systems + ignore-targets + (free-space-requirement + ;; 2G + (* 2 (expt 2 30))) + timeout) (define (fetch-new-jobs) (let ((free-space (free-disk-space "/gnu/store"))) - (if (< free-space (* 2 (expt 2 30))) ; 2G + (if (< free-space free-space-requirement) (begin (simple-format (current-error-port) @@ -148,9 +170,22 @@ guix-data-service: error: missing log line: ~A ,@(if skip-system-tests? '("--skip-system-tests") '()) + ,@(map (match-lambda + ((key . val) + (simple-format #f "--inferior-set-environment-variable=~A=~A" + key val))) + extra-inferior-environment-variables) ,@(if per-job-parallelism (list (simple-format #f "--parallelism=~A" per-job-parallelism)) - '())) + '()) + ,@(if (null? ignore-systems) + '() + (list (simple-format #f "--ignore-systems=~A" + (string-join ignore-systems ",")))) + ,@(if (null? ignore-targets) + '() + (list (simple-format #f "--ignore-targets=~A" + (string-join ignore-targets ","))))) #:output log-port #:error log-port))) @@ -171,7 +206,8 @@ guix-data-service: error: missing log line: ~A handle-job-failure #:max-processes max-processes #:priority-max-processes - latest-branch-revision-max-processes)) + latest-branch-revision-max-processes + #:timeout timeout)) (define* (log-for-job conn job-id @@ -279,10 +315,6 @@ WHERE job_id = $1") 4)) 1)) -(define default-timeout - (* (* 60 60) ;; 1 hour in seconds - 72)) - (define* (process-jobs-concurrently fetch-new-jobs process-job @@ -291,7 +323,7 @@ WHERE job_id = $1") #:key (max-processes default-max-processes) (priority-max-processes (* 2 max-processes)) - (timeout default-timeout)) + timeout) (define processes (make-hash-table)) @@ -302,9 +334,9 @@ WHERE job_id = $1") "\n\n" (let ((running-jobs (hash-count (const #t) processes))) (cond - ((eq? running-jobs 0) + ((= running-jobs 0) "status: 0 running jobs") - ((eq? running-jobs 1) + ((= running-jobs 1) "status: 1 running job") (else (simple-format #f "status: ~A running jobs" @@ -331,7 +363,7 @@ WHERE job_id = $1") (match (hash-ref processes pid) ((_ (id)) (post-job id) - (unless (eq? status 0) + (unless (= status 0) (simple-format (current-error-port) "pid ~A (job: ~A) failed with status ~A\n" pid id status) @@ -391,7 +423,8 @@ WHERE job_id = $1") (atomic-box-set! exit? #t))) (while #t - (kill-long-running-processes) + (when timeout + (kill-long-running-processes)) (wait-on-processes) (display-status) |