diff options
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 170 |
1 files changed, 86 insertions, 84 deletions
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 6913e39..d5170b8 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -1330,95 +1330,97 @@ (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 - ;; inferior. Even though the inferior %load-path and - ;; %load-compiled-path has the inferior modules first, this - ;; can cause issues when there are modules present outside - ;; of the inferior Guix which aren't present in the inferior - ;; Guix (like the new (guix lint) module - (unsetenv "GUILE_LOAD_PATH") - (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))) - (open-inferior/container store store-path - #:extra-shared-directories - '("/gnu/store") - #:extra-environment-variables - (list (string-append - "GUIX_LOCPATH=" - guix-locpath))) - (begin - (setenv "GUIX_LOCPATH" guix-locpath) - (simple-format #t "debug: using open-inferior\n") - (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")) - - ;; Normalise the locale for the inferior process - (with-exception-handler - (lambda (key . args) - (simple-format - (current-error-port) - "warning: failed to set locale to en_US.UTF-8: ~A ~A\n" - key args)) - (lambda () - (inferior-eval '(setlocale LC_ALL "en_US.UTF-8") inf))) - - (inferior-eval '(use-modules (srfi srfi-1) - (srfi srfi-34) - (srfi srfi-43) - (ice-9 history) - (guix grafts) - (guix derivations) - (gnu tests)) - inf) + (call-with-blocked-asyncs + (lambda () + (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 + ;; inferior. Even though the inferior %load-path and + ;; %load-compiled-path has the inferior modules first, this + ;; can cause issues when there are modules present outside + ;; of the inferior Guix which aren't present in the inferior + ;; Guix (like the new (guix lint) module + (unsetenv "GUILE_LOAD_PATH") + (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))) + (open-inferior/container store store-path + #:extra-shared-directories + '("/gnu/store") + #:extra-environment-variables + (list (string-append + "GUIX_LOCPATH=" + guix-locpath))) + (begin + (setenv "GUIX_LOCPATH" guix-locpath) + (simple-format #t "debug: using open-inferior\n") + (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")) + + ;; Normalise the locale for the inferior process + (with-exception-handler + (lambda (key . args) + (simple-format + (current-error-port) + "warning: failed to set locale to en_US.UTF-8: ~A ~A\n" + key args)) + (lambda () + (inferior-eval '(setlocale LC_ALL "en_US.UTF-8") inf))) + + (inferior-eval '(use-modules (srfi srfi-1) + (srfi srfi-34) + (srfi srfi-43) + (ice-9 history) + (guix grafts) + (guix derivations) + (gnu tests)) + inf) - (inferior-eval '(disable-value-history!) - inf) + (inferior-eval '(disable-value-history!) + inf) - ;; For G_ and P_ - (or (inferior-eval '(and (resolve-module '(guix i18n) #:ensure #f) - (use-modules (guix i18n)) - #t) - inf) - (inferior-eval '(use-modules (guix ui)) - inf)) + ;; For G_ and P_ + (or (inferior-eval '(and (resolve-module '(guix i18n) #:ensure #f) + (use-modules (guix i18n)) + #t) + inf) + (inferior-eval '(use-modules (guix ui)) + inf)) - (inferior-eval '(when (defined? '%graft?) (%graft? #f)) inf) + (inferior-eval '(when (defined? '%graft?) (%graft? #f)) inf) - ;; TODO Have Guix make this easier - ((@@ (guix inferior) ensure-store-bridge!) inf) - (non-blocking-port ((@@ (guix inferior) inferior-bridge-socket) inf)) + ;; TODO Have Guix make this easier + ((@@ (guix inferior) ensure-store-bridge!) inf) + (non-blocking-port ((@@ (guix inferior) inferior-bridge-socket) inf)) - inf)) + inf)))) (define* (extract-information-from conn long-running-store-connection guix-revision-id commit |