cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Support setting environment variables in the inferior

Browse source 
When processing jobs, this is mostly to allow setting GUIX_DOWNLOAD_METHODS.
This commit is contained in:
Christopher Baines 2024-06-24 15:17:52 +01:00
parent d7103eccc9
commit 31bd2156f7
5 changed files with 73 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

6
guix-data-service/jobs.scm
View file

@ -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))
'()))

41
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -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
(inferior (start-inferior-for-data-extration
inferior-store
store-path
guix-locpath)))
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,10 +2172,13 @@ SKIP LOCKED")
(lambda ()
(with-throw-handler #t
(lambda ()
(load-new-guix-revision conn
(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)

14
scripts/guix-data-service-process-job.in
View file

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

13
scripts/guix-data-service-process-jobs.in
View file

@ -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 _

1
tests/jobs-load-new-guix-revision.scm
View file

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