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))
