Skip to content
Snippets Groups Projects
Unverified Commit 4495e085 authored by Mathieu Othacehe's avatar Mathieu Othacehe
Browse files

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.
parent aa9099e4
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 354 additions and 95 deletions
.gitignore
+ 1
− 0
View file @ 4495e085
......@@ -30,3 +30,4 @@ Makefile
Makefile.in
pre-inst-env
stamp-vti
.tmp-mail
\ No newline at end of file
Makefile.am
+ 4
− 1
View file @ 4495e085
......@@ -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 \
......
bin/cuirass.in
+ 79
− 77
View file @ 4495e085
......@@ -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
......
src/cuirass/database.scm
+ 17
− 9
View file @ 4495e085
......@@ -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."
......
src/cuirass/mail.scm 0 → 100644
+ 76
− 0
View file @ 4495e085
;;; 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))))
src/cuirass/notification.scm 0 → 100644
+ 128
− 0
View file @ 4495e085
;;; 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)))
src/cuirass/remote-server.scm
+ 9
− 7
View file @ 4495e085
......@@ -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)))))))
src/schema.sql
+ 1
− 0
View file @ 4495e085
......@@ -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
);
......
src/sql/upgrade-5.sql 0 → 100644
+ 5
− 0
View file @ 4495e085
BEGIN TRANSACTION;
ALTER TABLE Specifications ADD COLUMN notifications TEXT;
COMMIT;
tests/database.scm
+ 31
− 1
View file @ 4495e085
......@@ -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
......
tests/mail.sh 0 → 100755
+ 3
− 0
View file @ 4495e085
#!/bin/bash
cp /dev/stdin .tmp-mail
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment