mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
Allow skipping processing system tests
Generating system test derivations are difficult, since you generally need to do potentially expensive builds for the system you're generating the system tests for. You might not want to disable grafts for instance because you might be trying to test whatever the test is testing in the context of grafts being enabled. I'm looking at skipping the system tests on data.guix.gnu.org, because they're not used and quite expensive to compute.
This commit is contained in:
parent
9e9fc1ba04
commit
3ba8418656
|
@ -26,14 +26,19 @@
|
||||||
default-max-processes))
|
default-max-processes))
|
||||||
|
|
||||||
(define* (process-jobs conn #:key max-processes
|
(define* (process-jobs conn #:key max-processes
|
||||||
latest-branch-revision-max-processes)
|
latest-branch-revision-max-processes
|
||||||
|
skip-system-tests?)
|
||||||
(define (fetch-new-jobs)
|
(define (fetch-new-jobs)
|
||||||
(fetch-unlocked-jobs conn))
|
(fetch-unlocked-jobs conn))
|
||||||
|
|
||||||
(define (process-job job-id)
|
(define (process-job job-id)
|
||||||
(execlp "guix-data-service-process-job"
|
(apply execlp
|
||||||
"guix-data-service-process-job"
|
"guix-data-service-process-job"
|
||||||
job-id))
|
"guix-data-service-process-job"
|
||||||
|
job-id
|
||||||
|
(if skip-system-tests?
|
||||||
|
'("--skip-system-tests")
|
||||||
|
'())))
|
||||||
|
|
||||||
(define (handle-job-failure job-id)
|
(define (handle-job-failure job-id)
|
||||||
(record-job-event conn job-id "failure")
|
(record-job-event conn job-id "failure")
|
||||||
|
|
|
@ -1473,7 +1473,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 store-path
|
||||||
|
#: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)
|
||||||
|
|
||||||
(let ((inf (start-inferior-for-data-extration store store-path)))
|
(let ((inf (start-inferior-for-data-extration store store-path)))
|
||||||
|
@ -1490,8 +1491,12 @@ WHERE job_id = $1")
|
||||||
(with-time-logging "getting inferior derivations"
|
(with-time-logging "getting inferior derivations"
|
||||||
(all-inferior-package-derivations store inf packages)))
|
(all-inferior-package-derivations store inf packages)))
|
||||||
(inferior-system-tests
|
(inferior-system-tests
|
||||||
(with-time-logging "getting inferior system tests"
|
(if skip-system-tests?
|
||||||
(all-inferior-system-tests inf store)))
|
(begin
|
||||||
|
(simple-format #t "debug: skipping system tests\n")
|
||||||
|
'())
|
||||||
|
(with-time-logging "getting inferior system tests"
|
||||||
|
(all-inferior-system-tests inf store))))
|
||||||
(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))))
|
||||||
|
@ -1636,7 +1641,8 @@ WHERE job_id = $1")
|
||||||
|
|
||||||
(prevent-inlining-for-tests load-channel-instances)
|
(prevent-inlining-for-tests load-channel-instances)
|
||||||
|
|
||||||
(define (load-new-guix-revision conn store git-repository-id commit)
|
(define* (load-new-guix-revision conn store git-repository-id commit
|
||||||
|
#:key skip-system-tests?)
|
||||||
(let* ((git-repository-fields
|
(let* ((git-repository-fields
|
||||||
(select-git-repository conn git-repository-id))
|
(select-git-repository conn git-repository-id))
|
||||||
(git-repository-url
|
(git-repository-url
|
||||||
|
@ -1663,7 +1669,9 @@ 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 store-item
|
||||||
|
#:skip-system-tests?
|
||||||
|
skip-system-tests?)
|
||||||
|
|
||||||
(if (defined? 'channel-news-for-commit
|
(if (defined? 'channel-news-for-commit
|
||||||
(resolve-module '(guix channels)))
|
(resolve-module '(guix channels)))
|
||||||
|
@ -2082,7 +2090,7 @@ SKIP LOCKED")
|
||||||
|
|
||||||
(prevent-inlining-for-tests setup-logging)
|
(prevent-inlining-for-tests setup-logging)
|
||||||
|
|
||||||
(define (process-load-new-guix-revision-job id)
|
(define* (process-load-new-guix-revision-job id #:key skip-system-tests?)
|
||||||
(with-postgresql-connection
|
(with-postgresql-connection
|
||||||
(simple-format #f "load-new-guix-revision ~A" id)
|
(simple-format #f "load-new-guix-revision ~A" id)
|
||||||
(lambda (conn)
|
(lambda (conn)
|
||||||
|
@ -2121,7 +2129,9 @@ SKIP LOCKED")
|
||||||
(load-new-guix-revision conn
|
(load-new-guix-revision conn
|
||||||
store
|
store
|
||||||
git-repository-id
|
git-repository-id
|
||||||
commit))))
|
commit
|
||||||
|
#:skip-system-tests?
|
||||||
|
skip-system-tests?))))
|
||||||
(lambda (key . args)
|
(lambda (key . args)
|
||||||
(simple-format (current-error-port)
|
(simple-format (current-error-port)
|
||||||
"error: load-new-guix-revision: ~A ~A\n"
|
"error: load-new-guix-revision: ~A ~A\n"
|
||||||
|
|
|
@ -38,6 +38,30 @@
|
||||||
;; Make stack traces more useful
|
;; Make stack traces more useful
|
||||||
(setenv "COLUMNS" "256")
|
(setenv "COLUMNS" "256")
|
||||||
|
|
||||||
(match (command-line)
|
(define %options
|
||||||
((name job)
|
(list (option '("skip-system-tests") #f #f
|
||||||
(process-load-new-guix-revision-job job)))
|
(lambda (opt name _ result)
|
||||||
|
(alist-cons 'skip-system-tests #t result)))))
|
||||||
|
|
||||||
|
(define %default-options '())
|
||||||
|
|
||||||
|
(define (parse-options args)
|
||||||
|
(args-fold
|
||||||
|
args %options
|
||||||
|
(lambda (opt name arg result)
|
||||||
|
(error "unrecognized option" name))
|
||||||
|
(lambda (arg result)
|
||||||
|
(alist-cons
|
||||||
|
'arguments
|
||||||
|
(cons arg
|
||||||
|
(or (assoc-ref result 'arguments)
|
||||||
|
'()))
|
||||||
|
(alist-delete 'arguments result)))
|
||||||
|
%default-options))
|
||||||
|
|
||||||
|
(let ((opts (parse-options (cdr (program-arguments)))))
|
||||||
|
(match (assq-ref opts 'arguments)
|
||||||
|
((job)
|
||||||
|
(process-load-new-guix-revision-job
|
||||||
|
job
|
||||||
|
#:skip-system-tests? (assq-ref opts 'skip-system-tests)))))
|
||||||
|
|
|
@ -41,7 +41,10 @@
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'latest-branch-revision-max-processes
|
(alist-cons 'latest-branch-revision-max-processes
|
||||||
(string->number arg)
|
(string->number arg)
|
||||||
result)))))
|
result)))
|
||||||
|
(option '("skip-system-tests") #f #f
|
||||||
|
(lambda (opt name _ result)
|
||||||
|
(alist-cons 'skip-system-tests #t result)))))
|
||||||
|
|
||||||
(define %default-options
|
(define %default-options
|
||||||
;; Alist of default option values
|
;; Alist of default option values
|
||||||
|
@ -70,4 +73,6 @@
|
||||||
#:max-processes (assq-ref opts 'max-processes)
|
#:max-processes (assq-ref opts 'max-processes)
|
||||||
#:latest-branch-revision-max-processes
|
#:latest-branch-revision-max-processes
|
||||||
(or (assq-ref opts 'latest-branch-revision-max-processes)
|
(or (assq-ref opts 'latest-branch-revision-max-processes)
|
||||||
(* 2 (assq-ref opts 'max-processes)))))))
|
(* 2 (assq-ref opts 'max-processes)))
|
||||||
|
#:skip-system-tests?
|
||||||
|
(assq-ref opts 'skip-system-tests)))))
|
||||||
|
|
|
@ -59,7 +59,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 store-path
|
||||||
|
#:key skip-system-tests?)
|
||||||
#t))
|
#t))
|
||||||
|
|
||||||
(mock
|
(mock
|
||||||
|
@ -170,7 +171,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 store-path
|
||||||
|
#:key skip-system-tests?)
|
||||||
#f))
|
#f))
|
||||||
|
|
||||||
(mock
|
(mock
|
||||||
|
|
Loading…
Reference in a new issue