cbaines pushed a commit to branch master in repository data-service. commit 31bd2156f72dcd9fbdecdd5210f218a93a8382ec Author: Christopher Baines <m...@cbaines.net> AuthorDate: Mon Jun 24 15:17:52 2024 +0100
Support setting environment variables in the inferior When processing jobs, this is mostly to allow setting GUIX_DOWNLOAD_METHODS. --- guix-data-service/jobs.scm | 6 +++ guix-data-service/jobs/load-new-guix-revision.scm | 51 ++++++++++++++++++----- scripts/guix-data-service-process-job.in | 14 ++++++- scripts/guix-data-service-process-jobs.in | 13 ++++++ tests/jobs-load-new-guix-revision.scm | 1 + 5 files changed, 73 insertions(+), 12 deletions(-) diff --git a/guix-data-service/jobs.scm b/guix-data-service/jobs.scm index 7d62be3..71d22ef 100644 --- a/guix-data-service/jobs.scm +++ b/guix-data-service/jobs.scm @@ -127,6 +127,7 @@ guix-data-service: error: missing log line: ~A (define* (process-jobs conn #:key max-processes latest-branch-revision-max-processes skip-system-tests? + extra-inferior-environment-variables per-job-parallelism) (define (fetch-new-jobs) (let ((free-space (free-disk-space "/gnu/store"))) @@ -148,6 +149,11 @@ 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)) '())) diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index d821157..6913e39 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -1328,8 +1328,14 @@ output))) -(define (start-inferior-for-data-extration store store-path guix-locpath) +(define (start-inferior-for-data-extration store store-path guix-locpath + extra-inferior-environment-variables) (let* ((original-guix-locpath (getenv "GUIX_LOCPATH")) + (original-extra-env-vars-values + (map (match-lambda + ((key . _) + (getenv key))) + extra-inferior-environment-variables)) (inf (begin ;; Unset the GUILE_LOAD_PATH and GUILE_LOAD_COMPILED_PATH to ;; avoid the values for these being used in the @@ -1342,6 +1348,15 @@ (unsetenv "GUILE_LOAD_COMPILED_PATH") (simple-format (current-error-port) "debug: set GUIX_LOCPATH to ~A\n" guix-locpath) + (for-each + (match-lambda + ((key . val) + (simple-format (current-error-port) + "debug: set ~A to ~A\n" + key val) + (setenv key val))) + extra-inferior-environment-variables) + (if (defined? 'open-inferior/container (resolve-module '(guix inferior))) @@ -1358,6 +1373,11 @@ (open-inferior store-path #:error-port (current-error-port))))))) (setenv "GUIX_LOCPATH" original-guix-locpath) ; restore GUIX_LOCPATH + (for-each + (lambda (key val) + (setenv key val)) + (map car extra-inferior-environment-variables) + original-extra-env-vars-values) (when (eq? inf #f) (error "error: inferior is #f")) @@ -1404,6 +1424,7 @@ guix-revision-id commit guix-source store-path #:key skip-system-tests? + extra-inferior-environment-variables parallelism) (define guix-locpath @@ -1422,12 +1443,13 @@ (make-resource-pool (lambda () (let* ((inferior-store (open-connection)) - (inferior (start-inferior-for-data-extration inferior-store - store-path - guix-locpath))) + (inferior (start-inferior-for-data-extration + inferior-store + store-path + guix-locpath + extra-inferior-environment-variables))) (ensure-non-blocking-store-connection inferior-store) (make-inferior-non-blocking! inferior) - (simple-format #t "debug: started new inferior and store connection\n") (cons inferior inferior-store))) @@ -1666,7 +1688,8 @@ (prevent-inlining-for-tests load-channel-instances) (define* (load-new-guix-revision conn git-repository-id commit - #:key skip-system-tests? parallelism) + #:key skip-system-tests? parallelism + extra-inferior-environment-variables) (let* ((git-repository-fields (select-git-repository conn git-repository-id)) (git-repository-url @@ -1712,6 +1735,8 @@ commit guix-source store-item #:skip-system-tests? skip-system-tests? + #:extra-inferior-environment-variables + extra-inferior-environment-variables #:parallelism parallelism))) (if (defined? 'channel-news-for-commit @@ -2115,6 +2140,7 @@ SKIP LOCKED") (prevent-inlining-for-tests with-store-connection) (define* (process-load-new-guix-revision-job id #:key skip-system-tests? + extra-inferior-environment-variables parallelism) (with-postgresql-connection (simple-format #f "load-new-guix-revision ~A" id) @@ -2146,11 +2172,14 @@ SKIP LOCKED") (lambda () (with-throw-handler #t (lambda () - (load-new-guix-revision conn - git-repository-id - commit - #:skip-system-tests? #t - #:parallelism parallelism)) + (load-new-guix-revision + conn + git-repository-id + commit + #:skip-system-tests? #t + #:extra-inferior-environment-variables + extra-inferior-environment-variables + #:parallelism parallelism)) (lambda (key . args) (simple-format (current-error-port) "error: load-new-guix-revision: ~A ~A\n" diff --git a/scripts/guix-data-service-process-job.in b/scripts/guix-data-service-process-job.in index df6142e..bb2f04a 100644 --- a/scripts/guix-data-service-process-job.in +++ b/scripts/guix-data-service-process-job.in @@ -51,7 +51,12 @@ (alist-cons 'parallelism (string->number arg) (alist-delete 'parallelism - result)))))) + result)))) + (option '("inferior-set-environment-variable") #t #f + (lambda (opt name arg result) + (alist-cons 'inferior-environment-variable + (string-split arg #\=) + result))))) (define %default-options '((parallelism . 1))) @@ -79,6 +84,13 @@ (process-load-new-guix-revision-job job #:skip-system-tests? (assq-ref opts 'skip-system-tests) + #:extra-inferior-environment-variables + (filter-map + (match-lambda + (('inferior-environment-variable key val) + (cons key val)) + (_ #f)) + opts) #:parallelism (assq-ref opts 'parallelism))) #:hz 0 #:parallelism 1))))) diff --git a/scripts/guix-data-service-process-jobs.in b/scripts/guix-data-service-process-jobs.in index ae1542c..cbe92f2 100644 --- a/scripts/guix-data-service-process-jobs.in +++ b/scripts/guix-data-service-process-jobs.in @@ -24,6 +24,7 @@ (use-modules (srfi srfi-1) (srfi srfi-37) + (ice-9 match) (guix-data-service database) (guix-data-service jobs)) @@ -49,6 +50,11 @@ (lambda (opt name arg result) (alist-cons 'per-job-parallelism (string->number arg) + result))) + (option '("inferior-set-environment-variable") #t #f + (lambda (opt name arg result) + (alist-cons 'inferior-environment-variable + (string-split arg #\=) result))))) (define %default-options @@ -95,6 +101,13 @@ (* 2 (assq-ref opts 'max-processes))) #:skip-system-tests? (assq-ref opts 'skip-system-tests) + #:extra-inferior-environment-variables + (filter-map + (match-lambda + (('inferior-environment-variable key val) + (cons key val)) + (_ #f)) + opts) #:per-job-parallelism (assq-ref opts 'per-job-parallelism))) (lambda _ diff --git a/tests/jobs-load-new-guix-revision.scm b/tests/jobs-load-new-guix-revision.scm index 1a64ce3..d914eaa 100644 --- a/tests/jobs-load-new-guix-revision.scm +++ b/tests/jobs-load-new-guix-revision.scm @@ -65,6 +65,7 @@ (lambda* (conn store guix-revision-id commit guix-source store-path #:key skip-system-tests? + extra-inferior-environment-variables parallelism) #t))