aboutsummaryrefslogtreecommitdiff
path: root/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'scripts')
-rw-r--r--scripts/guix-data-service-process-branch-updated-email.in24
-rw-r--r--scripts/guix-data-service-process-branch-updated-mbox.in27
-rw-r--r--scripts/guix-data-service-process-job.in30
-rw-r--r--scripts/guix-data-service-process-jobs.in80
-rw-r--r--scripts/guix-data-service.in10
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 ()