Set current-guix-package when computing system test derivations

This is a bit ugly, but might speed up computing derivations for system tests.

2 files changed, 120 insertions, 94 deletions

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index a44c675..862563a 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -374,64 +374,73 @@ WHERE job_id = $1")
      '(@ (guix packages) %supported-systems)
      inf))))
 
-(define (all-inferior-system-tests inf store)
+(define (all-inferior-system-tests inf store guix-source guix-commit)
   (define inf-systems
     (inferior-guix-systems inf))
 
   (define extract
     `(lambda (store)
-       (map
-        (lambda (system-test)
-          (let ((stats (gc-stats)))
-            (simple-format
-             (current-error-port)
-             "inferior heap: ~a MiB used (~a MiB heap)~%"
-             (round
-              (/ (- (assoc-ref stats 'heap-size)
-                    (assoc-ref stats 'heap-free-size))
-                 (expt 2. 20)))
-             (round
-              (/ (assoc-ref (gc-stats) 'heap-size)
-                 (expt 2. 20)))))
-
-          (list (system-test-name system-test)
-                (system-test-description system-test)
-                (filter-map
-                 (lambda (system)
-                   (simple-format
-                    (current-error-port)
-                    "guix-data-service: computing derivation for ~A system test (on ~A)\n"
-                    (system-test-name system-test)
-                    system)
-                   (catch
-                     #t
-                     (lambda ()
-                       (cons
-                        system
-                        (parameterize ((%current-system system))
-                          (derivation-file-name
-                           (run-with-store store
-                             (mbegin %store-monad
-                               (system-test-value system-test)))))))
-                     (lambda (key . args)
-                       (simple-format
-                        (current-error-port)
-                        "guix-data-service: error computing derivation for system test ~A (~A): ~A: ~A\n"
-                        (system-test-name system-test)
-                        system
-                        key args)
-                       #f)))
-                 (list ,@inf-systems))
-                (match (system-test-location system-test)
-                  (($ <location> file line column)
-                   (list file
-                         line
-                         column)))))
-        (all-system-tests))))
-
+       (parameterize ((current-guix-package
+                       (channel-source->package ,guix-source
+                                                #:commit ,guix-commit)))
+         (map
+          (lambda (system-test)
+            (let ((stats (gc-stats)))
+              (simple-format
+               (current-error-port)
+               "inferior heap: ~a MiB used (~a MiB heap)~%"
+               (round
+                (/ (- (assoc-ref stats 'heap-size)
+                      (assoc-ref stats 'heap-free-size))
+                   (expt 2. 20)))
+               (round
+                (/ (assoc-ref (gc-stats) 'heap-size)
+                   (expt 2. 20)))))
+
+            (list (system-test-name system-test)
+                  (system-test-description system-test)
+                  (filter-map
+                   (lambda (system)
+                     (simple-format
+                      (current-error-port)
+                      "guix-data-service: computing derivation for ~A system test (on ~A)\n"
+                      (system-test-name system-test)
+                      system)
+                     (catch
+                       #t
+                       (lambda ()
+                         (cons
+                          system
+                          (parameterize ((%current-system system))
+                            (derivation-file-name
+                             (run-with-store store
+                               (mbegin %store-monad
+                                 (system-test-value system-test)))))))
+                       (lambda (key . args)
+                         (simple-format
+                          (current-error-port)
+                          "guix-data-service: error computing derivation for system test ~A (~A): ~A: ~A\n"
+                          (system-test-name system-test)
+                          system
+                          key args)
+                         #f)))
+                   (list ,@inf-systems))
+                  (match (system-test-location system-test)
+                    (($ <location> file line column)
+                     (list file
+                           line
+                           column)))))
+          (all-system-tests)))))
+
+  (peek "GUIX SOURCE" guix-source)
   (catch
     #t
     (lambda ()
+      (inferior-eval
+       ;; For channel-source->package
+       '(use-modules (gnu packages package-management))
+       inf)
+
       (let ((system-test-data
              (with-time-logging "getting system tests"
                (inferior-eval-with-store inf store extract))))
@@ -1165,7 +1174,7 @@ WHERE job_id = $1")
       (build-derivations store (list derivation)))
     (derivation->output-path derivation)))
 
-(define (channel->derivation-file-names-by-system conn store channel
+(define (channel->source-and-derivation-file-names-by-system conn store channel
                                                   fetch-with-authentication?)
   (define use-container? (defined?
                            'open-inferior/container
@@ -1304,7 +1313,9 @@ WHERE job_id = $1")
 
             (close-inferior inferior)
 
-            result)))
+            (cons
+             (channel-instance-checkout channel-instance)
+             result))))
 
       (catch
         #t
@@ -1321,26 +1332,27 @@ WHERE job_id = $1")
           (close-inferior inferior)
           #f))))
 
-(define (channel->derivations-by-system conn store channel
-                                        fetch-with-authentication?)
-  (let ((derivation-file-names-by-system
-         (with-time-logging "computing the channel derivation"
-           (channel->derivation-file-names-by-system conn
-                                                     store
-                                                     channel
-                                                     fetch-with-authentication?))))
-    (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)
+(define (channel->source-and-derivations-by-system conn store channel
+                                                   fetch-with-authentication?)
+  (match (with-time-logging "computing the channel derivation"
+           (channel->source-and-derivation-file-names-by-system
+            conn
+            store
+            channel
+            fetch-with-authentication?))
+    ((source . derivation-file-names-by-system)
+     (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)
 
-    derivation-file-names-by-system))
+     (cons source derivation-file-names-by-system))))
 
-(prevent-inlining-for-tests channel->derivations-by-system)
+(prevent-inlining-for-tests channel->source-and-derivations-by-system)
 
 (define (channel-derivations-by-system->guix-store-item
          store
@@ -1473,7 +1485,8 @@ WHERE job_id = $1")
 
     inf))
 
-(define* (extract-information-from conn store guix-revision-id commit store-path
+(define* (extract-information-from conn store guix-revision-id commit
+                                   guix-source store-path
                                    #:key skip-system-tests?)
   (simple-format #t "debug: extract-information-from: ~A\n" store-path)
 
@@ -1496,7 +1509,8 @@ WHERE job_id = $1")
                       (simple-format #t "debug: skipping system tests\n")
                       '())
                     (with-time-logging "getting inferior system tests"
-                      (all-inferior-system-tests inf store))))
+                      (all-inferior-system-tests inf store
+                                                 guix-source commit))))
                (packages-data
                 (with-time-logging "getting all inferior package data"
                   (all-inferior-packages-data inf packages))))
@@ -1653,11 +1667,15 @@ WHERE job_id = $1")
           (channel (name 'guix)
                    (url git-repository-url)
                    (commit commit)))
+         (source-and-channel-derivations-by-system
+          (channel->source-and-derivations-by-system conn
+                                                     store
+                                                     channel-for-commit
+                                                     fetch-with-authentication?))
+         (guix-source
+          (car source-and-channel-derivations-by-system))
          (channel-derivations-by-system
-          (channel->derivations-by-system conn
-                                          store
-                                          channel-for-commit
-                                          fetch-with-authentication?))
+          (cdr source-and-channel-derivations-by-system))
          (guix-revision-id
           (load-channel-instances git-repository-id commit
                                   channel-derivations-by-system)))
@@ -1669,7 +1687,7 @@ WHERE job_id = $1")
           (and
            (extract-information-from conn store
                                      guix-revision-id
-                                     commit store-item
+                                     commit guix-source store-item
                                      #:skip-system-tests?
                                      skip-system-tests?)
 
diff --git a/tests/jobs-load-new-guix-revision.scm b/tests/jobs-load-new-guix-revision.scm
index 0f40e52..0eaad3f 100644
--- a/tests/jobs-load-new-guix-revision.scm
+++ b/tests/jobs-load-new-guix-revision.scm
@@ -37,12 +37,14 @@
 
       (mock
        ((guix-data-service jobs load-new-guix-revision)
-        channel->derivations-by-system
+        channel->source-and-derivations-by-system
         (lambda (conn store channel fetch-with-authentication?)
-          '(("x86_64-linux"
-             .
-             ((manifest-entry-item . "/gnu/store/foo.drv")
-              (profile . "/gnu/store/bar.drv"))))))
+          (cons
+           "/gnu/store/guix"
+           '(("x86_64-linux"
+              .
+              ((manifest-entry-item . "/gnu/store/foo.drv")
+               (profile . "/gnu/store/bar.drv")))))))
 
        (mock
         ((guix-data-service jobs load-new-guix-revision)
@@ -59,7 +61,8 @@
          (mock
           ((guix-data-service jobs load-new-guix-revision)
            extract-information-from
-           (lambda* (conn store guix-revision-id commit store-path
+           (lambda* (conn store guix-revision-id commit
+                          guix-source store-path
                           #:key skip-system-tests?)
              #t))
 
@@ -96,12 +99,14 @@
 
       (mock
        ((guix-data-service jobs load-new-guix-revision)
-        channel->derivations-by-system
+        channel->source-and-derivations-by-system
         (lambda (conn store channel fetch-with-authentication?)
-          '(("x86_64-linux"
-             .
-             ((manifest-entry-item . "/gnu/store/foo.drv")
-              (profile . "/gnu/store/bar.drv"))))))
+          (cons
+           "/gnu/store/guix"
+           '(("x86_64-linux"
+              .
+              ((manifest-entry-item . "/gnu/store/foo.drv")
+               (profile . "/gnu/store/bar.drv")))))))
 
        (mock
         ((guix-data-service jobs load-new-guix-revision)
@@ -142,12 +147,14 @@
 
       (mock
        ((guix-data-service jobs load-new-guix-revision)
-        channel->derivations-by-system
+        channel->source-and-derivations-by-system
         (lambda (conn store channel fetch-with-authentication?)
-          '(("x86_64-linux"
-             .
-             ((manifest-entry-item . "/gnu/store/foo.drv")
-              (profile . "/gnu/store/bar.drv"))))))
+          (cons
+           "/gnu/store/guix"
+           '(("x86_64-linux"
+              .
+              ((manifest-entry-item . "/gnu/store/foo.drv")
+               (profile . "/gnu/store/bar.drv")))))))
 
        (mock
         ((guix-data-service jobs load-new-guix-revision)
@@ -171,7 +178,8 @@
           (mock
            ((guix-data-service jobs load-new-guix-revision)
             extract-information-from
-            (lambda* (conn store git-repository-id commit store-path
+            (lambda* (conn store git-repository-id commit
+                           guix-source store-path
                            #:key skip-system-tests?)
               #f))