cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Set current-guix-package when computing system test derivations

Browse source 
This is a bit ugly, but might speed up computing derivations for system tests.
This commit is contained in:
Christopher Baines 2023-02-28 10:41:40 +00:00
parent 2d96fbff48
commit bf41c6ebb1
2 changed files with 118 additions and 92 deletions
Download patch file Download diff file Expand all files Collapse all files

50
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -374,12 +374,15 @@ WHERE job_id = $1")
'(@ (guix packages) %supported-systems) '(@ (guix packages) %supported-systems)
inf)))) inf))))
(define (all-inferior-system-tests inf store) (define (all-inferior-system-tests inf store guix-source guix-commit)
(define inf-systems (define inf-systems
(inferior-guix-systems inf)) (inferior-guix-systems inf))
(define extract (define extract
`(lambda (store) `(lambda (store)
(parameterize ((current-guix-package
(channel-source->package ,guix-source
#:commit ,guix-commit)))
(map (map
(lambda (system-test) (lambda (system-test)
(let ((stats (gc-stats))) (let ((stats (gc-stats)))
@ -427,11 +430,17 @@ WHERE job_id = $1")
(list file (list file
line line
column))))) column)))))
(all-system-tests)))) (all-system-tests)))))
(peek "GUIX SOURCE" guix-source)
(catch (catch
#t #t
(lambda () (lambda ()
(inferior-eval
;; For channel-source->package
'(use-modules (gnu packages package-management))
inf)
(let ((system-test-data (let ((system-test-data
(with-time-logging "getting system tests" (with-time-logging "getting system tests"
(inferior-eval-with-store inf store extract)))) (inferior-eval-with-store inf store extract))))
@ -1165,7 +1174,7 @@ WHERE job_id = $1")
(build-derivations store (list derivation))) (build-derivations store (list derivation)))
(derivation->output-path 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?) fetch-with-authentication?)
(define use-container? (defined? (define use-container? (defined?
'open-inferior/container 'open-inferior/container
@ -1304,7 +1313,9 @@ WHERE job_id = $1")
(close-inferior inferior) (close-inferior inferior)
result))) (cons
(channel-instance-checkout channel-instance)
result))))
(catch (catch
#t #t
@ -1321,14 +1332,15 @@ WHERE job_id = $1")
(close-inferior inferior) (close-inferior inferior)
#f)))) #f))))
(define (channel->derivations-by-system conn store channel (define (channel->source-and-derivations-by-system conn store channel
fetch-with-authentication?) fetch-with-authentication?)
(let ((derivation-file-names-by-system (match (with-time-logging "computing the channel derivation"
(with-time-logging "computing the channel derivation" (channel->source-and-derivation-file-names-by-system
(channel->derivation-file-names-by-system conn conn
store store
channel channel
fetch-with-authentication?)))) fetch-with-authentication?))
((source . derivation-file-names-by-system)
(for-each (for-each
(match-lambda (match-lambda
((system . derivation-file-name) ((system . derivation-file-name)
@ -1338,9 +1350,9 @@ WHERE job_id = $1")
derivation-file-name))) derivation-file-name)))
derivation-file-names-by-system) 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 (define (channel-derivations-by-system->guix-store-item
store store
@ -1473,7 +1485,8 @@ WHERE job_id = $1")
inf)) 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?) #:key skip-system-tests?)
(simple-format #t "debug: extract-information-from: ~A\n" store-path) (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") (simple-format #t "debug: skipping system tests\n")
'()) '())
(with-time-logging "getting inferior system tests" (with-time-logging "getting inferior system tests"
(all-inferior-system-tests inf store)))) (all-inferior-system-tests inf store
guix-source commit))))
(packages-data (packages-data
(with-time-logging "getting all inferior package data" (with-time-logging "getting all inferior package data"
(all-inferior-packages-data inf packages)))) (all-inferior-packages-data inf packages))))
@ -1653,11 +1667,15 @@ WHERE job_id = $1")
(channel (name 'guix) (channel (name 'guix)
(url git-repository-url) (url git-repository-url)
(commit commit))) (commit commit)))
(channel-derivations-by-system (source-and-channel-derivations-by-system
(channel->derivations-by-system conn (channel->source-and-derivations-by-system conn
store store
channel-for-commit channel-for-commit
fetch-with-authentication?)) fetch-with-authentication?))
(guix-source
(car source-and-channel-derivations-by-system))
(channel-derivations-by-system
(cdr source-and-channel-derivations-by-system))
(guix-revision-id (guix-revision-id
(load-channel-instances git-repository-id commit (load-channel-instances git-repository-id commit
channel-derivations-by-system))) channel-derivations-by-system)))
@ -1669,7 +1687,7 @@ WHERE job_id = $1")
(and (and
(extract-information-from conn store (extract-information-from conn store
guix-revision-id guix-revision-id
commit store-item commit guix-source store-item
#:skip-system-tests? #:skip-system-tests?
skip-system-tests?) skip-system-tests?)

24
tests/jobs-load-new-guix-revision.scm
View file

@ -37,12 +37,14 @@
(mock (mock
((guix-data-service jobs load-new-guix-revision) ((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?) (lambda (conn store channel fetch-with-authentication?)
(cons
"/gnu/store/guix"
'(("x86_64-linux" '(("x86_64-linux"
. .
((manifest-entry-item . "/gnu/store/foo.drv") ((manifest-entry-item . "/gnu/store/foo.drv")
(profile . "/gnu/store/bar.drv")))))) (profile . "/gnu/store/bar.drv")))))))
(mock (mock
((guix-data-service jobs load-new-guix-revision) ((guix-data-service jobs load-new-guix-revision)
@ -59,7 +61,8 @@
(mock (mock
((guix-data-service jobs load-new-guix-revision) ((guix-data-service jobs load-new-guix-revision)
extract-information-from 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?) #:key skip-system-tests?)
#t)) #t))
@ -96,12 +99,14 @@
(mock (mock
((guix-data-service jobs load-new-guix-revision) ((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?) (lambda (conn store channel fetch-with-authentication?)
(cons
"/gnu/store/guix"
'(("x86_64-linux" '(("x86_64-linux"
. .
((manifest-entry-item . "/gnu/store/foo.drv") ((manifest-entry-item . "/gnu/store/foo.drv")
(profile . "/gnu/store/bar.drv")))))) (profile . "/gnu/store/bar.drv")))))))
(mock (mock
((guix-data-service jobs load-new-guix-revision) ((guix-data-service jobs load-new-guix-revision)
@ -142,12 +147,14 @@
(mock (mock
((guix-data-service jobs load-new-guix-revision) ((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?) (lambda (conn store channel fetch-with-authentication?)
(cons
"/gnu/store/guix"
'(("x86_64-linux" '(("x86_64-linux"
. .
((manifest-entry-item . "/gnu/store/foo.drv") ((manifest-entry-item . "/gnu/store/foo.drv")
(profile . "/gnu/store/bar.drv")))))) (profile . "/gnu/store/bar.drv")))))))
(mock (mock
((guix-data-service jobs load-new-guix-revision) ((guix-data-service jobs load-new-guix-revision)
@ -171,7 +178,8 @@
(mock (mock
((guix-data-service jobs load-new-guix-revision) ((guix-data-service jobs load-new-guix-revision)
extract-information-from 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?) #:key skip-system-tests?)
#f)) #f))