[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Thu, 11 Mar 2021 04:27:28 -0500 (EST) |
branch: master
commit aabeced62ae23f148c29524dbc63d73467c3cd12
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Thu Mar 11 10:27:13 2021 +0100
Send notifications in a separate thread.
---
bin/cuirass.in | 148 +++++++++++++++++++++---------------------
src/cuirass/database.scm | 55 +++++++++++-----
src/cuirass/notification.scm | 54 ++++++---------
src/cuirass/remote-server.scm | 16 ++---
src/schema.sql | 6 +-
tests/database.scm | 61 ++++++++++++-----
6 files changed, 187 insertions(+), 153 deletions(-)
diff --git a/bin/cuirass.in b/bin/cuirass.in
index 421b22c..65c8f98 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -145,80 +145,80 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(run-fibers
(lambda ()
(with-database
- (with-notification
- (and specfile
- (for-each db-add-specification
- (read-specifications specfile)))
- (and paramfile (read-parameters paramfile))
-
- (if one-shot?
- (process-specs (db-get-specifications))
- (let ((exit-channel (make-channel)))
- (start-watchdog)
- (if (option-ref opts 'web #f)
- (begin
- (spawn-fiber
- (essential-task
- 'web exit-channel
- (lambda ()
- (run-cuirass-server #:host host
- #:port port)))
- #:parallel? #t)
-
- (spawn-fiber
- (essential-task
- 'monitor exit-channel
- (lambda ()
- (while #t
- (log-monitoring-stats)
- (sleep 600))))))
-
- (begin
- (clear-build-queue)
-
- ;; If Cuirass was stopped during an evaluation,
- ;; abort it. Builds that were not registered
- ;; during this evaluation will be registered
- ;; during the next evaluation.
- (db-abort-pending-evaluations)
-
- ;; First off, restart builds that had not
- ;; completed or were not even started on a
- ;; previous run.
- (spawn-fiber
- (essential-task
- 'restart-builds exit-channel
- (lambda ()
- (restart-builds))))
-
- (spawn-fiber
- (essential-task
- 'build exit-channel
- (lambda ()
- (while #t
- (process-specs (db-get-specifications))
- (log-message
- "next evaluation in ~a seconds" interval)
- (sleep interval)))))
-
- (spawn-fiber
- (essential-task
- 'metrics exit-channel
- (lambda ()
- (while #t
- (with-time-logging
- "Metrics update"
- (db-update-metrics))
- (sleep 3600)))))
-
- (spawn-fiber
- (essential-task
- 'monitor exit-channel
- (lambda ()
- (while #t
- (log-monitoring-stats)
- (sleep 600)))))))
- (primitive-exit (get-message exit-channel)))))))
+ (start-notification-thread)
+ (and specfile
+ (for-each db-add-specification
+ (read-specifications specfile)))
+ (and paramfile (read-parameters paramfile))
+
+ (if one-shot?
+ (process-specs (db-get-specifications))
+ (let ((exit-channel (make-channel)))
+ (start-watchdog)
+ (if (option-ref opts 'web #f)
+ (begin
+ (spawn-fiber
+ (essential-task
+ 'web exit-channel
+ (lambda ()
+ (run-cuirass-server #:host host
+ #:port port)))
+ #:parallel? #t)
+
+ (spawn-fiber
+ (essential-task
+ 'monitor exit-channel
+ (lambda ()
+ (while #t
+ (log-monitoring-stats)
+ (sleep 600))))))
+
+ (begin
+ (clear-build-queue)
+
+ ;; If Cuirass was stopped during an evaluation,
+ ;; abort it. Builds that were not registered
+ ;; during this evaluation will be registered
+ ;; during the next evaluation.
+ (db-abort-pending-evaluations)
+
+ ;; First off, restart builds that had not
+ ;; completed or were not even started on a
+ ;; previous run.
+ (spawn-fiber
+ (essential-task
+ 'restart-builds exit-channel
+ (lambda ()
+ (restart-builds))))
+
+ (spawn-fiber
+ (essential-task
+ 'build exit-channel
+ (lambda ()
+ (while #t
+ (process-specs (db-get-specifications))
+ (log-message
+ "next evaluation in ~a seconds" interval)
+ (sleep interval)))))
+
+ (spawn-fiber
+ (essential-task
+ 'metrics exit-channel
+ (lambda ()
+ (while #t
+ (with-time-logging
+ "Metrics update"
+ (db-update-metrics))
+ (sleep 3600)))))
+
+ (spawn-fiber
+ (essential-task
+ 'monitor exit-channel
+ (lambda ()
+ (while #t
+ (log-monitoring-stats)
+ (sleep 600)))))))
+ (primitive-exit (get-message exit-channel))))))
;; Most of our code is I/O so preemption doesn't matter much (it
;; could help while we're doing SQL requests, for instance, but it
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index bba970e..edbd193 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -95,6 +95,8 @@
db-get-builds-max
db-get-evaluation-specification
db-get-build-product-path
+ db-push-notification
+ db-pop-notification
db-add-or-update-worker
db-get-worker
db-get-workers
@@ -752,29 +754,26 @@ log file for DRV."
;; times in a row, for instance. The 'last_status' field is updated
;; with the status of the last completed build with the same
;; 'job_name' and 'specification'.
- (begin
- (let* ((last-status (db-get-last-status drv))
- (weather (build-status->weather status last-status))
- (rows
- (exec-query/bind db "
+ (let* ((last-status (db-get-last-status drv))
+ (weather (build-status->weather status last-status))
+ (rows
+ (exec-query/bind db "
UPDATE Builds SET stoptime =" now
", status =" status
", last_status = " last-status
", weather = " weather
"WHERE derivation =" drv
" AND status != " status ";")))
- (when (positive? rows)
- (let* ((build (db-get-build drv))
- (spec (assq-ref build #:specification))
- (specification (db-get-specification spec))
- (notifications
- (specification-notifications specification)))
- (send-notifications notifications #:build build)
- (db-add-event 'build
- now
- `((#:derivation . ,drv)
- (#:event . ,(assq-ref status-names
- status)))))))))))
+ (when (positive? rows)
+ (let* ((build (db-get-build drv))
+ (spec (assq-ref build #:specification))
+ (specification (db-get-specification spec))
+ (notifications
+ (specification-notifications specification)))
+ (for-each (lambda (notif)
+ (db-push-notification notif
+ (assq-ref build #:id)))
+ notifications)))))))
(define* (db-update-build-worker! drv worker)
"Update the database so that DRV's worker is WORKER."
@@ -1367,6 +1366,28 @@ WHERE id = " id))
((path) path)
(else #f))))
+(define (db-push-notification notification build)
+ "Insert NOTIFICATION into Notifications table."
+ (with-db-worker-thread db
+ (exec-query/bind db "\
+INSERT INTO Notifications (type, build)
+VALUES (" (notification->sexp notification) ", " build ");")))
+
+(define (db-pop-notification)
+ "Return two values, the latest notification from the Notifications table and
+the matching build."
+ (with-db-worker-thread db
+ (match (expect-one-row
+ (exec-query/bind db "
+SELECT id, type, build from Notifications ORDER BY id ASC LIMIT 1;"))
+ ((id type build)
+ (exec-query/bind db "\
+DELETE FROM Notifications WHERE id =" id ";")
+ (cons (sexp->notification
+ (with-input-from-string type read))
+ (db-get-build (string->number build))))
+ (else #f))))
+
(define (db-add-or-update-worker worker)
"Insert WORKER into Worker table."
(with-db-worker-thread db
diff --git a/src/cuirass/notification.scm b/src/cuirass/notification.scm
index 5688c77..7402467 100644
--- a/src/cuirass/notification.scm
+++ b/src/cuirass/notification.scm
@@ -17,13 +17,16 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (cuirass notification)
+ #:use-module (cuirass database)
#:use-module (cuirass logging)
#:use-module (cuirass mail)
#:use-module (cuirass mastodon)
#:use-module (cuirass parameters)
#:use-module (cuirass utils)
+ #:use-module (guix build syscalls)
#:use-module (guix records)
#:use-module (ice-9 match)
+ #:use-module (ice-9 threads)
#:export (email
email?
email-from
@@ -36,8 +39,7 @@
notification->sexp
sexp->notification
- with-notification
- send-notifications))
+ start-notification-thread))
;;;
@@ -89,27 +91,6 @@
(define weather-success 0)
(define weather-failure 1)
-;; The channel to communicate with the notification worker thread.
-(define %notification-channel
- (make-parameter #f))
-
-(define-syntax-rule (with-notification body ...)
- "Run BODY with %NOTIFICATION-CHANNEL being dynamically bound to a channel
-providing a worker thread that allows to send notifications without
-interfering with fibers."
- (parameterize ((%notification-channel
- (make-worker-thread-channel
- (const #t))))
- body ...))
-
-(define-syntax-rule (with-notification-worker-thread exp ...)
- "Evaluate EXP... in the critical section corresponding to
-%NOTIFICATION-CHANNEL."
- (call-with-worker-thread
- (%notification-channel)
- (lambda args
- exp ...)))
-
(define (build-weather-text build)
"Return the build weather string."
(let ((weather (assq-ref build #:weather)))
@@ -171,14 +152,19 @@ the detailed information about this build here: ~a."
(log-message "Failed to send the mastodon notification: ~a."
args)))))
-(define* (send-notifications notifications #:key build)
- "Send the notifications in NOTIFICATIONS list, regarding the given BUILD."
- (with-notification-worker-thread
- (for-each
- (lambda (notification)
- (cond
- ((email? notification)
- (send-email* notification build))
- ((mastodon? notification)
- (send-mastodon build))))
- notifications)))
+(define (start-notification-thread)
+ "Start a thread sending build notifications."
+ (call-with-new-thread
+ (lambda ()
+ (set-thread-name "notification")
+ (let loop ()
+ (match (db-pop-notification)
+ ((notif . build)
+ (cond
+ ((email? notif)
+ (send-email* notif build))
+ ((mastodon? notif)
+ (send-mastodon build))))
+ (#f #f))
+ (sleep 1)
+ (loop)))))
diff --git a/src/cuirass/remote-server.scm b/src/cuirass/remote-server.scm
index 4cd7f53..16a7e6c 100644
--- a/src/cuirass/remote-server.scm
+++ b/src/cuirass/remote-server.scm
@@ -508,11 +508,11 @@ exiting."
(receive-logs log-port (%cache-directory))
(with-database
- (with-notification
- (for-each (lambda (number)
- (start-fetch-worker
- (string-append "fetch-worker-"
- (number->string number))))
- (iota 4))
-
- (zmq-start-proxy backend-port)))))))
+ (start-notification-thread)
+ (for-each (lambda (number)
+ (start-fetch-worker
+ (string-append "fetch-worker-"
+ (number->string number))))
+ (iota 4))
+
+ (zmq-start-proxy backend-port))))))
diff --git a/src/schema.sql b/src/schema.sql
index 90b4e6a..de5e67d 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -84,11 +84,11 @@ CREATE TABLE BuildProducts (
FOREIGN KEY (build) REFERENCES Builds(id) ON DELETE CASCADE
);
-CREATE TABLE Events (
+CREATE TABLE Notifications (
id SERIAL PRIMARY KEY,
type TEXT NOT NULL,
- timestamp INTEGER NOT NULL,
- event_json TEXT NOT NULL
+ build INTEGER NOT NULL,
+ FOREIGN KEY (build) REFERENCES Builds(id) ON DELETE CASCADE
);
CREATE TABLE Workers (
diff --git a/tests/database.scm b/tests/database.scm
index a3af071..54dd7c2 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -103,11 +103,23 @@
(systems '("a" "b"))
(last-seen 1)))
+(define* (retry f #:key times delay)
+ (let loop ((attempt 1))
+ (let ((result (f)))
+ (cond
+ (result result)
+ (else
+ (if (>= attempt times)
+ #f
+ (begin
+ (sleep delay)
+ (loop (+ 1 attempt)))))))))
(test-group-with-cleanup "database"
(test-assert "db-init"
(begin
(test-init-db!)
+ (start-notification-thread)
#t))
(test-equal "db-add-specification"
@@ -231,17 +243,6 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(let ((build (db-get-build "/foo.drv")))
(assoc-ref build #:id)))
- (test-equal "db-get-events"
- 'evaluation
- (let ((event (match (db-get-events '((nr . 1)
- (type . evaluation)))
- ((event) event))))
- (assoc-ref event #:type)))
-
- (test-equal "db-delete-events-with-ids-<=-to"
- 1
- (db-delete-events-with-ids-<=-to 1))
-
(test-equal "db-get-pending-derivations"
'("/foo.drv")
(db-get-pending-derivations))
@@ -492,9 +493,14 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(test-assert "mail notification"
- (let ((str (call-with-input-file tmp-mail
- get-string-all)))
- (string-contains str "Build job-1 on guix is fixed.")))
+ (retry
+ (lambda ()
+ (and (file-exists? tmp-mail)
+ (let ((str (call-with-input-file tmp-mail
+ get-string-all)))
+ (string-contains str "Build job-1 on guix is fixed."))))
+ #:times 5
+ #:delay 1))
(test-equal "db-get-builds weather"
(build-weather new-failure)
@@ -504,9 +510,14 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(test-assert "mail notification"
- (let ((str (call-with-input-file tmp-mail
- get-string-all)))
- (string-contains str "Build job-1 on guix is broken.")))
+ (retry
+ (lambda ()
+ (and (file-exists? tmp-mail)
+ (let ((str (call-with-input-file tmp-mail
+ get-string-all)))
+ (string-contains str "Build job-1 on guix is broken."))))
+ #:times 5
+ #:delay 1))
(test-equal "db-get-builds weather"
(build-weather still-succeeding)
@@ -548,6 +559,22 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(eq? (assq-ref (db-get-build drv) #:status)
(build-status canceled))))
+ (test-assert "db-push-notification"
+ (let ((build (db-get-build "/new-build.drv")))
+ (db-push-notification
+ (email
+ (from "from")
+ (to "to")
+ (server (mailer)))
+ (assq-ref build #:id))))
+
+ (test-assert "db-pop-notification"
+ (let ((build (db-get-build "/new-build.drv")))
+ (match (db-pop-notification)
+ ((notif . notif-build)
+ (and (email? notif)
+ (equal? build notif-build))))))
+
(test-assert "db-close"
(begin
(db-close (%db))