diff options
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 172 | ||||
| -rw-r--r-- | 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)) |