[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/03: Set current-guix-package when computing system test derivations
|
From: |
Christopher Baines |
|
Subject: |
03/03: Set current-guix-package when computing system test derivations |
|
Date: |
Tue, 28 Feb 2023 05:52:02 -0500 (EST) |
cbaines pushed a commit to branch master
in repository data-service.
commit bf41c6ebb1c12ec15ee77e727a1ae0d7a1466aef
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Tue Feb 28 10:41:40 2023 +0000
Set current-guix-package when computing system test derivations
This is a bit ugly, but might speed up computing derivations for system
tests.
---
guix-data-service/jobs/load-new-guix-revision.scm | 172 ++++++++++++----------
tests/jobs-load-new-guix-revision.scm | 42 +++---
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))