[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Mon, 22 Feb 2021 03:09:12 -0500 (EST) |
branch: master
commit 4495e08542f6d401c79bd1ecc49898790c73a346
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sun Feb 21 09:35:04 2021 +0100
Add notifications support.
* src/cuirass/mail.scm: New file.
* src/cuirass/notification.scm: New file.
* src/sql/upgrade-5.sql: New file.
* Makefile.am (dist_pkgmodule_DATA, dist_sql_DATA): Add them.
* src/schema.sql (Specifications)[notifications]: New field.
* bin/cuirass.in: Wrap inside the "with-notification" macro.
* src/cuirass/remote-server.scm (remote-server): Ditto.
* src/cuirass/database.scm (db-add-specification): Add notifications field.
(db-get-specifications): Ditto.
(db-update-build-status!): Send notifications.
* tests/mail.sh: New file.
* tests/database.scm (mu-debug, tmp-mail): New variables.
(mailer): New procedure.
(example-spec): Add an email notification.
("mail-notification"): New test case.
---
.gitignore | 1 +
Makefile.am | 5 +-
bin/cuirass.in | 156 +++++++++++++++++++++---------------------
src/cuirass/database.scm | 26 ++++---
src/cuirass/mail.scm | 76 ++++++++++++++++++++
src/cuirass/notification.scm | 128 ++++++++++++++++++++++++++++++++++
src/cuirass/remote-server.scm | 16 +++--
src/schema.sql | 1 +
src/sql/upgrade-5.sql | 5 ++
tests/database.scm | 32 ++++++++-
tests/mail.sh | 3 +
11 files changed, 354 insertions(+), 95 deletions(-)
diff --git a/.gitignore b/.gitignore
index 7cd0e1f..a67fb93 100644
--- a/.gitignore
+++ b/.gitignore
@@ -30,3 +30,4 @@ Makefile
Makefile.in
pre-inst-env
stamp-vti
+.tmp-mail
\ No newline at end of file
diff --git a/Makefile.am b/Makefile.am
index 6d20aee..dbcc87b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -53,7 +53,9 @@ dist_pkgmodule_DATA = \
src/cuirass/database.scm \
src/cuirass/http.scm \
src/cuirass/logging.scm \
+ src/cuirass/mail.scm \
src/cuirass/metrics.scm \
+ src/cuirass/notification.scm \
src/cuirass/remote.scm \
src/cuirass/remote-server.scm \
src/cuirass/remote-worker.scm \
@@ -84,7 +86,8 @@ dist_sql_DATA = \
src/sql/upgrade-1.sql \
src/sql/upgrade-2.sql \
src/sql/upgrade-3.sql \
- src/sql/upgrade-4.sql
+ src/sql/upgrade-4.sql \
+ src/sql/upgrade-5.sql
dist_css_DATA = \
src/static/css/cuirass.css \
diff --git a/bin/cuirass.in b/bin/cuirass.in
index b3cca1f..e5b7ff9 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -32,6 +32,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(cuirass ui)
(cuirass logging)
(cuirass metrics)
+ (cuirass notification)
(cuirass utils)
(cuirass watchdog)
(cuirass zabbix)
@@ -145,83 +146,84 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(run-fibers
(lambda ()
(with-database
- (and specfile
- (let ((new-specs (save-module-excursion
- (lambda ()
- (set-current-module
- (make-user-module '()))
- (primitive-load specfile)))))
-
- (for-each db-add-specification new-specs)))
-
- (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))))))
+ (with-notification
+ (and specfile
+ (let ((new-specs (save-module-excursion
+ (lambda ()
+ (set-current-module
+ (make-user-module '()))
+ (primitive-load specfile)))))
+
+ (for-each db-add-specification new-specs)))
+
+ (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 2f12ed9..eef5d8e 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -24,6 +24,7 @@
(define-module (cuirass database)
#:use-module (cuirass logging)
#:use-module (cuirass config)
+ #:use-module (cuirass notification)
#:use-module (cuirass remote)
#:use-module (cuirass utils)
#:use-module (squee)
@@ -250,8 +251,7 @@ fibers."
(define-syntax-rule (with-db-worker-thread db exp ...)
"Evaluate EXP... in the critical section corresponding to %DB-CHANNEL.
-DB is bound to the argument of that critical section: the database connection.
-This must only be used for reading queries, i.e SELECT queries."
+DB is bound to the argument of that critical section: the database connection."
(let ((send-timeout 2)
(receive-timeout 5)
(caller-name (frame-procedure-name
@@ -405,7 +405,7 @@ table."
(exec-query/bind db "\
INSERT INTO Specifications (name, load_path_inputs, \
package_path_inputs, proc_input, proc_file, proc, proc_args, \
-build_outputs, priority) \
+build_outputs, notifications, priority) \
VALUES ("
(assq-ref spec #:name) ", "
(assq-ref spec #:load-path-inputs) ", "
@@ -415,6 +415,7 @@ build_outputs, priority) \
(symbol->string (assq-ref spec #:proc)) ", "
(assq-ref spec #:proc-args) ", "
(assq-ref spec #:build-outputs) ", "
+ (assq-ref spec #:notifications) ", "
(or (assq-ref spec #:priority) max-priority) ")
ON CONFLICT ON CONSTRAINT specifications_pkey DO NOTHING
RETURNING name;"))
@@ -472,7 +473,7 @@ SELECT * FROM Specifications ORDER BY name ASC;")))
(match rows
(() (reverse specs))
(((name load-path-inputs package-path-inputs proc-input proc-file proc
- proc-args build-outputs priority)
+ proc-args build-outputs notifications priority)
. rest)
(loop rest
(cons `((#:name . ,name)
@@ -487,6 +488,8 @@ SELECT * FROM Specifications ORDER BY name ASC;")))
(#:inputs . ,(db-get-inputs name))
(#:build-outputs .
,(with-input-from-string build-outputs read))
+ (#:notifications .
+ ,(with-input-from-string notifications read))
(#:priority . ,(string->number priority)))
specs)))))))
@@ -823,11 +826,16 @@ UPDATE Builds SET stoptime =" now
"WHERE derivation =" drv
" AND status != " status ";")))
(when (positive? rows)
- (db-add-event 'build
- now
- `((#:derivation . ,drv)
- (#:event . ,(assq-ref status-names
- status))))))))))
+ (let* ((build (db-get-build drv))
+ (spec (assq-ref build #:specification))
+ (specification (db-get-specification spec))
+ (notifications (assq-ref specification #:notifications)))
+ (send-notifications notifications #:build build)
+ (db-add-event 'build
+ now
+ `((#:derivation . ,drv)
+ (#:event . ,(assq-ref status-names
+ status)))))))))))
(define* (db-update-build-worker! drv worker)
"Update the database so that DRV's worker is WORKER."
diff --git a/src/cuirass/mail.scm b/src/cuirass/mail.scm
new file mode 100644
index 0000000..3706e6b
--- /dev/null
+++ b/src/cuirass/mail.scm
@@ -0,0 +1,76 @@
+;;; mail.scm -- Send mails.
+;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass mail)
+ #:use-module (cuirass utils)
+ #:use-module (mailutils mailutils)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-19)
+ #:export (send-email))
+
+;; This variable is looked up by 'mu-message-send'.
+(define-public mu-debug 0)
+
+;; Copied from (mumi send-email).
+(define* (compute-message-id message #:optional seed)
+ "Return a message ID string."
+ (string-append "<" (number->string (object-address message) 16)
+ "." (number->string
+ (or seed
+ (string-hash
+ (or (mu-message-get-header message "Subject")
+ "")))
+ 16)
+ "@guile.gnu.org>"))
+
+(define* (send-email url
+ #:key
+ from to
+ (date (time-utc->date (current-time time-utc)))
+ subject text)
+ "Send an email to URL. Use the FROM, TO, DATE and SUBJECT arguments to set
+the MIME headers. TEXT is copied as the email body.
+
+This method supports sendmail and SMTP methods. The URL syntax is described
+here: https://mailutils.org/manual/html_node/Mailbox.html#Mailbox.";
+ (mu-register-format (if (string-prefix? "sendmail" url)
+ "sendmail"
+ "smtp"))
+ (let* ((mime (mu-mime-create))
+ (message (mu-message-create))
+ (body (mu-message-get-port message "w")))
+ (mu-message-set-header message
+ "Content-Type"
+ "text/plain; charset=utf-8")
+ (put-bytevector body (string->utf8 text))
+ (newline body)
+ (close-port body)
+ (mu-mime-add-part mime message)
+
+ (let ((message* (mu-mime-get-message mime)))
+ (mu-message-set-header message* "From" from)
+ (mu-message-set-header message* "To" to)
+ (mu-message-set-header message* "Date" (date->rfc822-str date))
+ (mu-message-set-header message* "Message-ID"
+ (compute-message-id message
+ (and=> text string-hash)))
+ (when subject
+ (mu-message-set-header message* "Subject" subject))
+
+ (mu-message-send message* url))))
diff --git a/src/cuirass/notification.scm b/src/cuirass/notification.scm
new file mode 100644
index 0000000..0b20ed8
--- /dev/null
+++ b/src/cuirass/notification.scm
@@ -0,0 +1,128 @@
+;;; notification.scm -- Send build notifications.
+;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; 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 utils)
+ #:export (notification-type
+ notification-event
+
+ with-notification
+ send-notifications))
+
+;; XXX: Some redefinitions to avoid a circular dependency with the (cuirass
+;; database) module.
+(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-enumeration notification-type
+ (email 0))
+
+(define-enumeration notification-event
+ (always 0)
+ (broken-builds 1)
+ (fixed-builds 2))
+
+(define (build-weather-text build)
+ "Return the build weather string."
+ (let ((weather (assq-ref build #:weather)))
+ (cond
+ ((= weather weather-success)
+ "fixed")
+ ((= weather weather-failure)
+ "broken"))))
+
+(define (notification-subject notification)
+ "Return the subject for the given NOTIFICATION."
+ (let* ((build (assq-ref notification #:build))
+ (job-name (assq-ref build #:job-name))
+ (specification (assq-ref build #:specification))
+ (weather-text (build-weather-text build)))
+ (format #f "Build ~a on ~a is ~a."
+ job-name specification weather-text)))
+
+(define (notification-text notification)
+ "Return the text for the given NOTIFICATION."
+ (let* ((build (assq-ref notification #:build))
+ (id (assq-ref build #:id))
+ (job-name (assq-ref build #:job-name))
+ (specification (assq-ref build #:specification))
+ (weather-text (build-weather-text build)))
+ (format #f "The build ~a for specification ~a is ~a. You can find
+the detailed information about this build here: ~a."
+ job-name specification weather-text
+ (string-append "build/" (number->string id) "/details"))))
+
+(define (notification-email notification)
+ "Send an email for the given NOTIFICATION."
+ (let* ((from (assq-ref notification #:from))
+ (to (assq-ref notification #:to))
+ (server (assq-ref notification #:server))
+ (subject (notification-subject notification))
+ (text (notification-text notification)))
+ (send-email server
+ #:from from
+ #:to to
+ #:subject subject
+ #:text text)))
+
+(define* (send-notifications notifications #:key build)
+ "Send the notifications in NOTIFICATIONS list, regarding the given BUILD."
+ (with-notification-worker-thread
+ (for-each
+ (lambda (notification)
+ (let* ((event (assq-ref notification #:event))
+ (type (assq-ref notification #:type))
+ (weather (assq-ref build #:weather))
+ (success? (eq? weather weather-success))
+ (failure? (eq? weather weather-failure)))
+ (when (or
+ (and (eq? event (notification-event always))
+ (or success? failure?))
+ (and (eq? event (notification-event broken-builds))
+ failure?)
+ (and (eq? event (notification-event fixed-builds))
+ success?))
+ (let ((notification* (acons #:build build notification)))
+ (cond
+ ((eq? type (notification-type email))
+ (notification-email notification*)))))))
+ notifications)))
diff --git a/src/cuirass/remote-server.scm b/src/cuirass/remote-server.scm
index 6c94673..404ed02 100644
--- a/src/cuirass/remote-server.scm
+++ b/src/cuirass/remote-server.scm
@@ -21,6 +21,7 @@
#:use-module (cuirass config)
#:use-module (cuirass database)
#:use-module (cuirass logging)
+ #:use-module (cuirass notification)
#:use-module (cuirass remote)
#:use-module (cuirass utils)
#:use-module (gcrypt pk-crypto)
@@ -479,10 +480,11 @@ exiting."
(receive-logs log-port (%cache-directory))
(with-database
- (for-each (lambda (number)
- (start-fetch-worker
- (string-append "fetch-worker-"
- (number->string number))))
- (iota 4))
-
- (zmq-start-proxy backend-port))))))
+ (with-notification
+ (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 81063b9..66194a9 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -13,6 +13,7 @@ CREATE TABLE Specifications (
proc TEXT NOT NULL, -- defined in proc_file
proc_args TEXT NOT NULL, -- passed to proc
build_outputs TEXT NOT NULL, --specify what build outputs should be made
available for download
+ notifications TEXT,
priority INTEGER NOT NULL DEFAULT 0
);
diff --git a/src/sql/upgrade-5.sql b/src/sql/upgrade-5.sql
new file mode 100644
index 0000000..117d052
--- /dev/null
+++ b/src/sql/upgrade-5.sql
@@ -0,0 +1,5 @@
+BEGIN TRANSACTION;
+
+ALTER TABLE Specifications ADD COLUMN notifications TEXT;
+
+COMMIT;
diff --git a/tests/database.scm b/tests/database.scm
index 8c39216..9736911 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -21,16 +21,30 @@
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(use-modules (cuirass database)
+ (cuirass notification)
(cuirass remote)
(cuirass utils)
((guix utils) #:select (call-with-temporary-output-file))
+ (rnrs io ports)
(squee)
(ice-9 match)
(srfi srfi-19)
(srfi srfi-64))
+;; This variable is looked up by 'mu-message-send'.
+(define-public mu-debug 0)
+
+(define (mailer)
+ (string-append "sendmail://" (getcwd) "/tests/mail.sh"))
+
+;; The above bash program will be invoked by mailutils. It copies what's
+;; passed on the standard input to the following file.
+(define tmp-mail ".tmp-mail")
+
+(false-if-exception (delete-file tmp-mail))
+
(define example-spec
- '((#:name . "guix")
+ `((#:name . "guix")
(#:load-path-inputs . ("savannah"))
(#:package-path-inputs . ())
(#:proc-input . "savannah")
@@ -52,6 +66,12 @@
(#:commit . #f)
(#:no-compile? . #f))))
(#:build-outputs . ())
+ (#:notifications . (((#:name . "name")
+ (#:type . ,(notification-type email))
+ (#:from . "from")
+ (#:to . "to")
+ (#:server . ,(mailer))
+ (#:event . 0))))
(#:priority . 9)))
(define (make-dummy-checkouts fakesha1 fakesha2)
@@ -469,6 +489,11 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(begin
(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.")))
+
(test-equal "db-get-builds weather"
(build-weather new-failure)
(begin
@@ -476,6 +501,11 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(db-update-build-status! "/new-build.drv" 1)
(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.")))
+
(test-equal "db-get-builds weather"
(build-weather still-succeeding)
(begin
diff --git a/tests/mail.sh b/tests/mail.sh
new file mode 100755
index 0000000..1be38a7
--- /dev/null
+++ b/tests/mail.sh
@@ -0,0 +1,3 @@
+#!/bin/bash
+
+cp /dev/stdin .tmp-mail