Set current-guix-package when computing system test derivations
This is a bit ugly, but might speed up computing derivations for system tests.
This commit is contained in:
parent
2d96fbff48
commit
bf41c6ebb1
2 changed files with 118 additions and 92 deletions
|
|
@ -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)))))
|
||||
(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))))
|
||||
(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?)
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue