diff options
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 178 |
1 files changed, 118 insertions, 60 deletions
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 6f57366..9d2992b 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -714,64 +714,71 @@ WHERE job_id = $1" (build-derivations store (list derivation)))) (derivation->output-path derivation))) -(define (channel->derivation-file-name store channel) +(define (channel->derivation-file-names-by-system store channel) (define use-container? (defined? 'open-inferior/container (resolve-module '(guix inferior)))) - (define inferior-code + (define (inferior-code channel-instance systems) `(lambda (store) - (let ((instances - (list - (channel-instance - (channel (name ',(channel-name channel)) - (url ,(channel-url channel)) - (branch ,(channel-branch channel)) - (commit ,(channel-commit channel))) - ,(channel-instance-commit channel-instance) - ,(channel-instance-checkout channel-instance))))) - (run-with-store store - (mlet* %store-monad ((manifest (channel-instances->manifest - instances)) - (derv (profile-derivation manifest))) - (mbegin %store-monad - (return (derivation-file-name derv)))))))) - - (define (start-inferior-and-return-derivation-file-names) - ;; /etc is only missing if open-inferior/container has been used - (when use-container? - (inferior-eval - '(begin - ;; Create /etc/pass, as %known-shorthand-profiles in (guix - ;; profiles) tries to read from this file. Because the environment - ;; is cleaned in build-self.scm, xdg-directory in (guix utils) - ;; falls back to accessing /etc/passwd. - (mkdir "/etc") - (call-with-output-file "/etc/passwd" - (lambda (port) - (display "root:x:0:0::/root:/bin/bash" port)))) - inferior)) - - (let ((channel-instance - (first - (latest-channel-instances store - (list channel))))) - (inferior-eval '(use-modules (guix channels) - (guix profiles)) - inferior) - (inferior-eval '(define channel-instance - (@@ (guix channels) channel-instance)) - inferior) - - (let ((result - (inferior-eval-with-store - inferior - store - inferior-code))) - - (close-inferior inferior) - - result))) + (let* ((instances + (list + (channel-instance + (channel (name ',(channel-name channel)) + (url ,(channel-url channel)) + (branch ,(channel-branch channel)) + (commit ,(channel-commit channel))) + ,(channel-instance-commit channel-instance) + ,(channel-instance-checkout channel-instance))))) + (map + (lambda (system) + (log-time + (simple-format + #f "computing the derivation-file-name for ~A" + system) + (lambda () + (with-store store + ((set-current-system system) store) + (let ((manifest + (catch #t + (lambda () + ((channel-instances->manifest instances) store)) + (lambda (key . args) + (simple-format + (current-error-port) + "error: while computing manifest entry derivation for ~A\n" + system) + (simple-format + (current-error-port) + "error ~A: ~A\n" key args) + #f)))) + `(,system + . + ((manifest-entry-item + . ,(and manifest + (derivation-file-name + (manifest-entry-item + (first + (manifest-entries manifest)))))) + (profile + . ,(catch #t + (lambda () + (and manifest + (derivation-file-name + (run-with-store store + (profile-derivation + manifest + #:hooks %channel-profile-hooks))))) + (lambda (key . args) + (simple-format + (current-error-port) + "error: while computing profile derivation for ~A\n" + system) + (simple-format + (current-error-port) + "error ~A: ~A\n" key args) + #f)))))))))) + (list ,@systems))))) (let ((inferior (if use-container? @@ -788,6 +795,49 @@ WHERE job_id = $1" (open-inferior (guix-store-path store) #:error-port (real-error-port)))))) + (define (start-inferior-and-return-derivation-file-names) + ;; /etc is only missing if open-inferior/container has been used + (when use-container? + (inferior-eval + '(begin + ;; Create /etc/pass, as %known-shorthand-profiles in (guix + ;; profiles) tries to read from this file. Because the environment + ;; is cleaned in build-self.scm, xdg-directory in (guix utils) + ;; falls back to accessing /etc/passwd. + (mkdir "/etc") + (call-with-output-file "/etc/passwd" + (lambda (port) + (display "root:x:0:0::/root:/bin/bash" port)))) + inferior)) + + (let ((channel-instance + (first + (latest-channel-instances store + (list channel))))) + (inferior-eval '(use-modules (srfi srfi-1) + (guix channels) + (guix grafts) + (guix profiles)) + inferior) + (inferior-eval '(when (defined? '%graft?) (%graft? #f)) + inferior) + (inferior-eval '(define channel-instance + (@@ (guix channels) channel-instance)) + inferior) + + (let* ((systems + (inferior-eval '(@ (guix packages) %supported-systems) + inferior)) + (result + (inferior-eval-with-store + inferior + store + (inferior-code channel-instance systems)))) + + (close-inferior inferior) + + result))) + (catch #t (lambda () @@ -797,14 +847,14 @@ WHERE job_id = $1" (display (backtrace) (current-error-port)) (display "\n" (current-error-port)) (simple-format (current-error-port) - "error: channel->derivation-file-name: ~A: ~A\n" + "error: channel->derivation-file-names-by-system: ~A: ~A\n" key parameters)))) (lambda args (close-inferior inferior) #f)))) (define (channel->manifest-store-item conn store channel) - (let* ((manifest-store-item-derivation-file-name + (let* ((derivation-file-names-by-system (log-time "computing the channel derivation" (lambda () @@ -814,12 +864,20 @@ WHERE job_id = $1" conn 'channel->manifest-store-item (lambda () - (channel->derivation-file-name store channel)))))) + (channel->derivation-file-names-by-system store channel)))))) (derivation - (read-derivation-from-file manifest-store-item-derivation-file-name))) - (simple-format (current-error-port) - "debug: channel dervation: ~A\n" - manifest-store-item-derivation-file-name) + (read-derivation-from-file (assoc-ref + (assoc-ref derivation-file-names-by-system + (%current-system)) + 'profile)))) + (for-each + (match-lambda + ((system . derivation-file-name) + (simple-format (current-error-port) + "debug: ~A: channel dervation: ~A\n" + system + derivation-file-name))) + derivation-file-names-by-system) (log-time "building the channel derivation" (lambda () |