Start computing channel instance derivations for multiple systems

These aren't stored yet, but this is a start.

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