diff options
Diffstat (limited to 'scripts')
| -rw-r--r-- | scripts/guix-data-service-process-branch-updated-email.in | 24 | ||||
| -rw-r--r-- | scripts/guix-data-service-process-branch-updated-mbox.in | 27 | ||||
| -rw-r--r-- | scripts/guix-data-service-process-job.in | 30 | ||||
| -rw-r--r-- | scripts/guix-data-service-process-jobs.in | 80 | ||||
| -rw-r--r-- | scripts/guix-data-service.in | 10 |
5 files changed, 118 insertions, 53 deletions
diff --git a/scripts/guix-data-service-process-branch-updated-email.in b/scripts/guix-data-service-process-branch-updated-email.in index d8f6196..a0e97ae 100644 --- a/scripts/guix-data-service-process-branch-updated-email.in +++ b/scripts/guix-data-service-process-branch-updated-email.in @@ -27,6 +27,7 @@ (rnrs bytevectors) (squee) (email email) + (knots) (guix-data-service database) (guix-data-service branch-updated-emails)) @@ -35,20 +36,17 @@ (lambda (conn) (let* ((email-bytevector (get-bytevector-all (current-input-port)))) - (catch - #t + (with-exception-handler + (lambda _ #f) (lambda () - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (display "\nerror: while parsing email\n" + (current-error-port)) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () (enqueue-job-for-email conn - (parse-email email-bytevector))) - (lambda (key . args) - (display "\nerror: while parsing email\n" - (current-error-port)) - (simple-format (current-error-port) - "~A: ~A\n\n" - key - args) - (display-backtrace (make-stack #t) (current-error-port))))) - (lambda (key . args) #f))))) + (parse-email email-bytevector))))) + #:unwind? #t)))) diff --git a/scripts/guix-data-service-process-branch-updated-mbox.in b/scripts/guix-data-service-process-branch-updated-mbox.in index 0a79f40..5773341 100644 --- a/scripts/guix-data-service-process-branch-updated-mbox.in +++ b/scripts/guix-data-service-process-branch-updated-mbox.in @@ -27,6 +27,7 @@ (rnrs bytevectors) (squee) (email email) + (knots) (guix-data-service database) (guix-data-service model git-repository) (guix-data-service branch-updated-emails)) @@ -36,7 +37,7 @@ (lambda (conn) (let ((count (count-git-repositories-with-x-git-repo-header-values conn))) - (when (eq? count 0) + (when (= count 0) (display "\nerror: no git_repositories exist with a value for x_git_repo_header error: to match emails to repositories, the git_repositories entry must have @@ -52,23 +53,21 @@ a x_git_repo_header value\n" (for-each (lambda (email-bytevector) (display "." (current-error-port)) - (catch - #t + (with-exception-handler + (lambda (exn) + #f) (lambda () - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (display "\nerror: while parsing email\n" + (current-error-port)) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () (enqueue-job-for-email conn - (parse-email email-bytevector))) - (lambda (key . args) - (display "\nerror: while parsing email\n" - (current-error-port)) - (simple-format (current-error-port) - "~A: ~A\n\n" - key - args) - (display-backtrace (make-stack #t) (current-error-port))))) - (lambda (key . args) #f))) + (parse-email email-bytevector))))) + #:unwind? #t)) (call-with-input-file file mbox->emails)) diff --git a/scripts/guix-data-service-process-job.in b/scripts/guix-data-service-process-job.in index df6142e..5643246 100644 --- a/scripts/guix-data-service-process-job.in +++ b/scripts/guix-data-service-process-job.in @@ -51,10 +51,27 @@ (alist-cons 'parallelism (string->number arg) (alist-delete 'parallelism - result)))))) + result)))) + (option '("inferior-set-environment-variable") #t #f + (lambda (opt name arg result) + (alist-cons 'inferior-environment-variable + (string-split arg #\=) + result))) + (option '("ignore-systems") #t #f + (lambda (opt name arg result) + (alist-cons 'ignore-systems + (string-split arg #\,) + result))) + (option '("ignore-targets") #t #f + (lambda (opt name arg result) + (alist-cons 'ignore-targets + (string-split arg #\,) + result))))) (define %default-options - '((parallelism . 1))) + '((parallelism . 1) + (ignore-systems . ()) + (ignore-targets . ()))) (define (parse-options args) (args-fold @@ -79,6 +96,15 @@ (process-load-new-guix-revision-job job #:skip-system-tests? (assq-ref opts 'skip-system-tests) + #:extra-inferior-environment-variables + (filter-map + (match-lambda + (('inferior-environment-variable key val) + (cons key val)) + (_ #f)) + opts) + #:ignore-systems (assq-ref opts 'ignore-systems) + #:ignore-targets (assq-ref opts 'ignore-targets) #:parallelism (assq-ref opts 'parallelism))) #:hz 0 #:parallelism 1))))) diff --git a/scripts/guix-data-service-process-jobs.in b/scripts/guix-data-service-process-jobs.in index ae1542c..ede8581 100644 --- a/scripts/guix-data-service-process-jobs.in +++ b/scripts/guix-data-service-process-jobs.in @@ -24,6 +24,8 @@ (use-modules (srfi srfi-1) (srfi srfi-37) + (ice-9 match) + (knots) (guix-data-service database) (guix-data-service jobs)) @@ -49,12 +51,42 @@ (lambda (opt name arg result) (alist-cons 'per-job-parallelism (string->number arg) + result))) + (option '("inferior-set-environment-variable") #t #f + (lambda (opt name arg result) + (alist-cons 'inferior-environment-variable + (string-split arg #\=) + result))) + (option '("free-space-requirement") #t #f + (lambda (opt name arg result) + (alist-cons 'free-space-requirement + (string->number arg) + result))) + (option '("ignore-systems") #t #f + (lambda (opt name arg result) + (alist-cons 'ignore-systems + (string-split arg #\,) + result))) + (option '("ignore-targets") #t #f + (lambda (opt name arg result) + (alist-cons 'ignore-targets + (string-split arg #\,) + result))) + (option '("timeout") #t #f + (lambda (opt name arg result) + (alist-cons 'timeout + (string->number arg) result))))) + (define %default-options ;; Alist of default option values `((max-processes . ,default-max-processes) - (per-job-parallelism . 1))) + (per-job-parallelism . 1) + (ignore-systems . ()) + (ignore-targets . ()) + (timeout . ,(* (* 60 60) ;; 1 hour in seconds + 72)))) (define (parse-options args) (args-fold @@ -79,24 +111,34 @@ (simple-format #t "Ready to process jobs...\n") (with-exception-handler (lambda (exn) - (simple-format - (current-error-port) - "exception: ~A\n" - exn) (exit 1)) (lambda () - (with-throw-handler #t - (lambda () - (process-jobs - conn - #: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))) - #:skip-system-tests? - (assq-ref opts 'skip-system-tests) - #:per-job-parallelism - (assq-ref opts 'per-job-parallelism))) - (lambda _ - (backtrace)))) + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (process-jobs + conn + #: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))) + #:skip-system-tests? + (assq-ref opts 'skip-system-tests) + #:extra-inferior-environment-variables + (filter-map + (match-lambda + (('inferior-environment-variable key val) + (cons key val)) + (_ #f)) + opts) + #:per-job-parallelism + (assq-ref opts 'per-job-parallelism) + #:ignore-systems (assq-ref opts 'ignore-systems) + #:ignore-targets (assq-ref opts 'ignore-targets) + #:free-space-requirement + (assq-ref opts 'free-space-requirement) + #:timeout + (assq-ref opts 'timeout))))) #:unwind? #t)))) diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in index 8a124ee..238483d 100644 --- a/scripts/guix-data-service.in +++ b/scripts/guix-data-service.in @@ -137,13 +137,13 @@ (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) +(unless (getenv "COLUMNS") + (setenv "COLUMNS" "128")) + (let ((opts (parse-options (cdr (program-arguments))))) (when (assq-ref opts 'repl) ((@@ (ice-9 top-repl) call-with-sigint) - (lambda () - (with-postgresql-connection-per-thread - "repl" - start-repl))) + start-repl) (exit 0)) (let ((repl-port (assoc-ref opts 'listen-repl))) @@ -197,7 +197,7 @@ (lambda (port) (simple-format port "~A\n" (getpid))))) - (start-substitute-query-threads) + (start-substitute-query-threads startup-completed) (call-with-new-thread (lambda () |