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

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

@ -374,64 +374,73 @@ 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)
(map (parameterize ((current-guix-package
(lambda (system-test) (channel-source->package ,guix-source
(let ((stats (gc-stats))) #:commit ,guix-commit)))
(simple-format (map
(current-error-port) (lambda (system-test)
"inferior heap: ~a MiB used (~a MiB heap)~%" (let ((stats (gc-stats)))
(round (simple-format
(/ (- (assoc-ref stats 'heap-size) (current-error-port)
(assoc-ref stats 'heap-free-size)) "inferior heap: ~a MiB used (~a MiB heap)~%"
(expt 2. 20))) (round
(round (/ (- (assoc-ref stats 'heap-size)
(/ (assoc-ref (gc-stats) 'heap-size) (assoc-ref stats 'heap-free-size))
(expt 2. 20))))) (expt 2. 20)))
(round
(/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20)))))
(list (system-test-name system-test) (list (system-test-name system-test)
(system-test-description system-test) (system-test-description system-test)
(filter-map (filter-map
(lambda (system) (lambda (system)
(simple-format (simple-format
(current-error-port) (current-error-port)
"guix-data-service: computing derivation for ~A system test (on ~A)\n" "guix-data-service: computing derivation for ~A system test (on ~A)\n"
(system-test-name system-test) (system-test-name system-test)
system) system)
(catch (catch
#t #t
(lambda () (lambda ()
(cons (cons
system system
(parameterize ((%current-system system)) (parameterize ((%current-system system))
(derivation-file-name (derivation-file-name
(run-with-store store (run-with-store store
(mbegin %store-monad (mbegin %store-monad
(system-test-value system-test))))))) (system-test-value system-test)))))))
(lambda (key . args) (lambda (key . args)
(simple-format (simple-format
(current-error-port) (current-error-port)
"guix-data-service: error computing derivation for system test ~A (~A): ~A: ~A\n" "guix-data-service: error computing derivation for system test ~A (~A): ~A: ~A\n"
(system-test-name system-test) (system-test-name system-test)
system system
key args) key args)
#f))) #f)))
(list ,@inf-systems)) (list ,@inf-systems))
(match (system-test-location system-test) (match (system-test-location system-test)
(($ <location> file line column) (($ <location> file line column)
(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,26 +1332,27 @@ 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?))
(for-each ((source . derivation-file-names-by-system)
(match-lambda (for-each
((system . derivation-file-name) (match-lambda
(simple-format (current-error-port) ((system . derivation-file-name)
"debug: ~A: channel dervation: ~A\n" (simple-format (current-error-port)
system "debug: ~A: channel dervation: ~A\n"
derivation-file-name))) system
derivation-file-names-by-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 (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)))
(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
(channel->derivations-by-system conn (cdr source-and-channel-derivations-by-system))
store
channel-for-commit
fetch-with-authentication?))
(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?)

42
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?)
'(("x86_64-linux" (cons
. "/gnu/store/guix"
((manifest-entry-item . "/gnu/store/foo.drv") '(("x86_64-linux"
(profile . "/gnu/store/bar.drv")))))) .
((manifest-entry-item . "/gnu/store/foo.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?)
'(("x86_64-linux" (cons
. "/gnu/store/guix"
((manifest-entry-item . "/gnu/store/foo.drv") '(("x86_64-linux"
(profile . "/gnu/store/bar.drv")))))) .
((manifest-entry-item . "/gnu/store/foo.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?)
'(("x86_64-linux" (cons
. "/gnu/store/guix"
((manifest-entry-item . "/gnu/store/foo.drv") '(("x86_64-linux"
(profile . "/gnu/store/bar.drv")))))) .
((manifest-entry-item . "/gnu/store/foo.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))