Support setting environment variables in the inferior

When processing jobs, this is mostly to allow setting GUIX_DOWNLOAD_METHODS.

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