diff options
| -rw-r--r-- | guix-data-service/jobs.scm | 13 | ||||
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 24 | ||||
| -rw-r--r-- | scripts/guix-data-service-process-job.in | 30 | ||||
| -rw-r--r-- | scripts/guix-data-service-process-jobs.in | 9 | ||||
| -rw-r--r-- | tests/jobs-load-new-guix-revision.scm | 6 |
5 files changed, 64 insertions, 18 deletions
diff --git a/guix-data-service/jobs.scm b/guix-data-service/jobs.scm index 8945e43..56c3ce7 100644 --- a/guix-data-service/jobs.scm +++ b/guix-data-service/jobs.scm @@ -26,14 +26,19 @@ default-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) (fetch-unlocked-jobs conn)) (define (process-job job-id) - (execlp "guix-data-service-process-job" - "guix-data-service-process-job" - job-id)) + (apply execlp + "guix-data-service-process-job" + "guix-data-service-process-job" + job-id + (if skip-system-tests? + '("--skip-system-tests") + '()))) (define (handle-job-failure job-id) (record-job-event conn job-id "failure") diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 57d6e77..a44c675 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -1473,7 +1473,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 store-path + #:key skip-system-tests?) (simple-format #t "debug: extract-information-from: ~A\n" 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" (all-inferior-package-derivations store inf packages))) (inferior-system-tests - (with-time-logging "getting inferior system tests" - (all-inferior-system-tests inf store))) + (if skip-system-tests? + (begin + (simple-format #t "debug: skipping system tests\n") + '()) + (with-time-logging "getting inferior system tests" + (all-inferior-system-tests inf store)))) (packages-data (with-time-logging "getting all inferior package data" (all-inferior-packages-data inf packages)))) @@ -1636,7 +1641,8 @@ WHERE job_id = $1") (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 (select-git-repository conn git-repository-id)) (git-repository-url @@ -1663,7 +1669,9 @@ WHERE job_id = $1") (and (extract-information-from conn store guix-revision-id - commit store-item) + commit store-item + #:skip-system-tests? + skip-system-tests?) (if (defined? 'channel-news-for-commit (resolve-module '(guix channels))) @@ -2082,7 +2090,7 @@ SKIP LOCKED") (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 (simple-format #f "load-new-guix-revision ~A" id) (lambda (conn) @@ -2121,7 +2129,9 @@ SKIP LOCKED") (load-new-guix-revision conn store git-repository-id - commit)))) + commit + #:skip-system-tests? + skip-system-tests?)))) (lambda (key . args) (simple-format (current-error-port) "error: load-new-guix-revision: ~A ~A\n" diff --git a/scripts/guix-data-service-process-job.in b/scripts/guix-data-service-process-job.in index e67e4e2..c6d06c6 100644 --- a/scripts/guix-data-service-process-job.in +++ b/scripts/guix-data-service-process-job.in @@ -38,6 +38,30 @@ ;; Make stack traces more useful (setenv "COLUMNS" "256") -(match (command-line) - ((name job) - (process-load-new-guix-revision-job job))) +(define %options + (list (option '("skip-system-tests") #f #f + (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))))) diff --git a/scripts/guix-data-service-process-jobs.in b/scripts/guix-data-service-process-jobs.in index 4a7af52..fb0385e 100644 --- a/scripts/guix-data-service-process-jobs.in +++ b/scripts/guix-data-service-process-jobs.in @@ -41,7 +41,10 @@ (lambda (opt name arg result) (alist-cons 'latest-branch-revision-max-processes (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 ;; Alist of default option values @@ -70,4 +73,6 @@ #:max-processes (assq-ref opts 'max-processes) #: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))))) diff --git a/tests/jobs-load-new-guix-revision.scm b/tests/jobs-load-new-guix-revision.scm index b70d702..0f40e52 100644 --- a/tests/jobs-load-new-guix-revision.scm +++ b/tests/jobs-load-new-guix-revision.scm @@ -59,7 +59,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 store-path + #:key skip-system-tests?) #t)) (mock @@ -170,7 +171,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 store-path + #:key skip-system-tests?) #f)) (mock |