[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Tue, 29 Dec 2020 12:46:38 -0500 (EST) |
branch: wip-offload
commit a2c4519915753267424ab467332ec0c111a0c48f
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Wed Dec 2 11:13:33 2020 +0100
Add remote build support.
* src/cuirass/remote.scm: New file.
* src/cuirass/remote-server.scm: New file.
* src/cuirass/remote-worker.scm: New file.
* bin/remote-server.in: New file.
* bin/remote-worker.in: New file.
* Makefile.am (bin_SCRIPTS): Add new binaries,
(dist_pkgmodule_DATA): add new files,
(EXTRA_DIST): add new binaries,
(bin/remote-server, bin/remote-worker): new targets.
* .gitignore: Add new binaries.
* bin/cuirass.in (%options): Add "--build-remote" option,
(show-help): document it,
(main): honor it.
* src/cuirass/base.scm (with-build-offload-thread): New macro,
(%build-remote?, %build-offload-channel): new parameters,
(make-build-offload-thread): new procedure,
(build-derivations/offload): new procedure,
(restart-builds): use it to offload builds when %build-remote? is set,
(build-packages): ditto.
---
.gitignore | 2 +
Makefile.am | 20 +-
bin/cuirass.in | 161 ++++++------
bin/remote-server.in | 29 +++
bin/remote-worker.in | 29 +++
src/cuirass/base.scm | 33 ++-
src/cuirass/database.scm | 121 +++++++--
src/cuirass/http.scm | 41 +--
src/cuirass/metrics.scm | 80 +++---
src/cuirass/remote-server.scm | 594 ++++++++++++++++++++++++++++++++++++++++++
src/cuirass/remote-worker.scm | 370 ++++++++++++++++++++++++++
src/cuirass/remote.scm | 331 +++++++++++++++++++++++
src/cuirass/templates.scm | 42 ++-
src/schema.sql | 18 +-
src/sql/upgrade-17.sql | 2 +-
src/sql/upgrade-18.sql | 10 +
src/sql/upgrade-19.sql | 11 +
tests/database.scm | 3 +-
tests/http.scm | 6 -
19 files changed, 1719 insertions(+), 184 deletions(-)
diff --git a/.gitignore b/.gitignore
index beabf29..7cd0e1f 100644
--- a/.gitignore
+++ b/.gitignore
@@ -12,6 +12,8 @@
/bin/cuirass
/bin/cuirass-send-events
/bin/evaluate
+/bin/remote-server
+/bin/remote-worker
/build-aux/config.guess
/build-aux/config.sub
/build-aux/install-sh
diff --git a/Makefile.am b/Makefile.am
index 72cb5a6..59d2c25 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -22,7 +22,13 @@
# You should have received a copy of the GNU General Public License
# along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
-bin_SCRIPTS = bin/cuirass bin/cuirass-send-events bin/evaluate
+bin_SCRIPTS = \
+ bin/cuirass \
+ bin/cuirass-send-events \
+ bin/evaluate \
+ bin/remote-server \
+ bin/remote-worker
+
noinst_SCRIPTS = pre-inst-env
guilesitedir = $(datarootdir)/guile/site/@GUILE_EFFECTIVE_VERSION@
@@ -48,6 +54,9 @@ dist_pkgmodule_DATA = \
src/cuirass/http.scm \
src/cuirass/logging.scm \
src/cuirass/metrics.scm \
+ src/cuirass/remote.scm \
+ src/cuirass/remote-server.scm \
+ src/cuirass/remote-worker.scm \
src/cuirass/send-events.scm \
src/cuirass/ui.scm \
src/cuirass/utils.scm \
@@ -86,7 +95,9 @@ dist_sql_DATA = \
src/sql/upgrade-14.sql \
src/sql/upgrade-15.sql \
src/sql/upgrade-16.sql \
- src/sql/upgrade-17.sql
+ src/sql/upgrade-17.sql \
+ src/sql/upgrade-18.sql \
+ src/sql/upgrade-19.sql
dist_css_DATA = \
src/static/css/cuirass.css \
@@ -167,6 +178,8 @@ EXTRA_DIST = \
bin/cuirass.in \
bin/cuirass-send-events.in \
bin/evaluate.in \
+ bin/remote-server.in \
+ bin/remote-worker.in \
bootstrap \
build-aux/guix.scm \
src/cuirass/config.scm.in \
@@ -227,6 +240,9 @@ generate_file = \
bin/cuirass: $(srcdir)/bin/cuirass.in
bin/cuirass-send-events: $(srcdir)/bin/cuirass-send-events.in
bin/evaluate: $(srcdir)/bin/evaluate.in
+bin/remote-server: $(srcdir)/bin/remote-server.in
+bin/remote-worker: $(srcdir)/bin/remote-worker.in
+
$(bin_SCRIPTS): Makefile
$(generate_file); chmod +x $@
src/cuirass/config.scm: $(srcdir)/src/cuirass/config.scm.in Makefile
diff --git a/bin/cuirass.in b/bin/cuirass.in
index fb0c0fe..20c2447 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -59,6 +59,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
-I, --interval=N Wait N seconds between each poll
-Q, --queue-size=N Set the writer queue size to N elements.
--log-queries=FILE Log SQL queries in FILE.
+ --build-remote Use the remote build mechanism
--use-substitutes Allow usage of pre-built substitutes
--record-events Record events for distribution
--threads=N Use up to N kernel threads
@@ -77,6 +78,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(listen (value #t))
(interval (single-char #\I) (value #t))
(queue-size (single-char #\Q) (value #t))
+ (build-remote (value #f))
(use-substitutes (value #f))
(threads (value #t))
(fallback (value #f))
@@ -103,6 +105,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(%package-database (option-ref opts 'database (%package-database)))
(%package-cachedir
(option-ref opts 'cache-directory (%package-cachedir)))
+ (%build-remote? (option-ref opts 'build-remote #f))
(%use-substitutes? (option-ref opts 'use-substitutes #f))
(%fallback? (option-ref opts 'fallback #f))
(%record-events? (option-ref opts 'record-events #f))
@@ -146,84 +149,86 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(lambda ()
(with-database
(with-queue-writer-worker
- (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)))
-
- (when queries-file
- (log-message "Enable SQL query logging.")
- (db-log-queries queries-file))
-
- (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)))))))
+ (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)))
+
+ (when queries-file
+ (log-message "Enable SQL query logging.")
+ (db-log-queries queries-file))
+
+ (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/bin/remote-server.in b/bin/remote-server.in
new file mode 100644
index 0000000..6425d51
--- /dev/null
+++ b/bin/remote-server.in
@@ -0,0 +1,29 @@
+#!/bin/sh
+# -*- scheme -*-
+# @configure_input@
+#GUILE_LOAD_PATH="@PACKAGE_LOAD_PATH@${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
+#GUILE_LOAD_COMPILED_PATH="@PACKAGE_LOAD_COMPILED_PATH@${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
+exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
+!#
+;;; remote-server.in -- Remote build server.
+;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass. If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass remote-server))
+
+(define* (main #:optional (args (command-line)))
+ (remote-server (cdr args)))
diff --git a/bin/remote-worker.in b/bin/remote-worker.in
new file mode 100644
index 0000000..8a3830c
--- /dev/null
+++ b/bin/remote-worker.in
@@ -0,0 +1,29 @@
+#!/bin/sh
+# -*- scheme -*-
+# @configure_input@
+#GUILE_LOAD_PATH="@PACKAGE_LOAD_PATH@${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
+#GUILE_LOAD_COMPILED_PATH="@PACKAGE_LOAD_COMPILED_PATH@${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
+exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
+!#
+;;; remote-worker.in -- Remote build worker.
+;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass. If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass remote-worker))
+
+(define* (main #:optional (args (command-line)))
+ (remote-worker (cdr args)))
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 5d3a456..53b9832 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -22,8 +22,10 @@
(define-module (cuirass base)
#:use-module (fibers)
+ #:use-module (fibers channels)
#:use-module (cuirass logging)
#:use-module (cuirass database)
+ #:use-module (cuirass remote)
#:use-module (cuirass utils)
#:use-module ((cuirass config) #:select (%localstatedir))
#:use-module (gnu packages)
@@ -36,9 +38,13 @@
#:use-module ((guix config) #:select (%state-directory))
#:use-module (git)
#:use-module (ice-9 binary-ports)
+ #:use-module ((ice-9 suspendable-ports)
+ #:select (current-read-waiter
+ current-write-waiter))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
+ #:use-module (ice-9 ports internal)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
@@ -58,6 +64,7 @@
fetch-inputs
compile
evaluate
+ set-build-successful!
clear-build-queue
cancel-old-builds
restart-builds
@@ -70,6 +77,7 @@
%package-cachedir
%gc-root-directory
%gc-root-ttl
+ %build-remote?
%use-substitutes?
%fallback?))
@@ -102,6 +110,10 @@
(define time-monotonic time-tai))
(else #t))
+(define %build-remote?
+ ;; Define whether to use the remote build mechanism.
+ (make-parameter #f))
+
(define %use-substitutes?
;; Define whether to use substitutes
(make-parameter #f))
@@ -446,7 +458,7 @@ Essentially this procedure inverts the inversion-of-control
that
;; Our shuffling algorithm is simple: we sort by .drv file name. :-)
(sort drv string<?))
-(define (set-build-successful! drv)
+(define* (set-build-successful! drv #:optional log)
"Update the build status of DRV as successful and register any eventual
build products."
(let* ((build (db-get-build drv))
@@ -456,7 +468,8 @@ build products."
(when (and spec build)
(create-build-outputs build
(assq-ref spec #:build-outputs))))
- (db-update-build-status! drv (build-status succeeded)))
+ (db-update-build-status! drv (build-status succeeded)
+ #:log-file log))
(define (update-build-statuses! store lst)
"Update the build status of the derivations listed in LST, which have just
@@ -584,7 +597,7 @@ updating the database accordingly."
(log-message "bogus build-started event for '~a'" drv)))
(('build-remote drv host _ ...)
(log-message "'~a' offloaded to '~a'" drv host)
- (db-update-build-machine! drv host))
+ (db-update-build-worker! drv host))
(('build-succeeded drv _ ...)
(if (valid? drv)
(begin
@@ -642,7 +655,8 @@ started)."
;; Those in VALID can be restarted. If some of them were built in the
;; meantime behind our back, that's fine: 'spawn-builds' will DTRT.
(log-message "restarting ~a pending builds" (length valid))
- (spawn-builds store valid)
+ (unless (%build-remote?)
+ (spawn-builds store valid))
(log-message "done with restarted builds"))))
(define (create-build-outputs build product-specs)
@@ -682,16 +696,19 @@ by PRODUCT-SPECS."
(define (build-packages store jobs eval-id)
"Build JOBS and return a list of Build results."
(define derivations
- (with-time-logging
- (format #f "evaluation ~a registration" eval-id)
- (db-register-builds jobs eval-id)))
+ (let* ((name (db-get-evaluation-specification eval-id))
+ (specification (db-get-specification name)))
+ (with-time-logging
+ (format #f "evaluation ~a registration" eval-id)
+ (db-register-builds jobs eval-id specification))))
(log-message "evaluation ~a registered ~a new derivations"
eval-id (length derivations))
(db-set-evaluation-status eval-id
(evaluation-status succeeded))
- (spawn-builds store derivations)
+ (unless (%build-remote?)
+ (spawn-builds store derivations))
(let* ((results (filter-map (cut db-get-build <>) derivations))
(status (map (cut assq-ref <> #:status) results))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 4ef5229..236f192 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 remote)
#:use-module (cuirass utils)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
@@ -60,7 +61,7 @@
db-add-build-product
db-register-builds
db-update-build-status!
- db-update-build-machine!
+ db-update-build-worker!
db-get-output
db-get-inputs
db-get-build
@@ -82,6 +83,9 @@
db-get-evaluation-specification
db-get-build-product-path
db-get-build-products
+ db-add-worker
+ db-get-workers
+ db-clear-workers
db-get-evaluation-summary
db-get-checkouts
read-sql-file
@@ -92,6 +96,7 @@
;; Constants.
SQLITE_CONSTRAINT_PRIMARYKEY
SQLITE_CONSTRAINT_UNIQUE
+ SQLITE_BUSY_SNAPSHOT
;; Parameters.
%package-database
%package-schema-file
@@ -106,6 +111,9 @@
with-database
with-queue-writer-worker))
+;; Maximum priority for a Build or Specification.
+(define max-priority 9)
+
(define (%sqlite-exec db sql . args)
"Evaluate the given SQL query with the given ARGS. Return the list of
rows."
@@ -441,7 +449,7 @@ table."
(sqlite-exec db "\
INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \
package_path_inputs, proc_input, proc_file, proc, proc_args, \
-build_outputs) \
+build_outputs, priority) \
VALUES ("
(assq-ref spec #:name) ", "
(assq-ref spec #:load-path-inputs) ", "
@@ -450,7 +458,8 @@ build_outputs) \
(assq-ref spec #:proc-file) ", "
(symbol->string (assq-ref spec #:proc)) ", "
(assq-ref spec #:proc-args) ", "
- (assq-ref spec #:build-outputs) ");")
+ (assq-ref spec #:build-outputs) ", "
+ (or (assq-ref spec #:priority) max-priority) ");")
(let ((spec-id (last-insert-rowid db)))
(for-each (lambda (input)
(db-add-input (assq-ref spec #:name) input))
@@ -504,7 +513,7 @@ SELECT * FROM Specifications ORDER BY name DESC;")))
(match rows
(() specs)
((#(name load-path-inputs package-path-inputs proc-input proc-file
proc
- proc-args build-outputs)
+ proc-args build-outputs priority)
. rest)
(loop rest
(cons `((#:name . ,name)
@@ -518,7 +527,8 @@ SELECT * FROM Specifications ORDER BY name DESC;")))
(#:proc-args . ,(with-input-from-string proc-args
read))
(#:inputs . ,(db-get-inputs name))
(#:build-outputs .
- ,(with-input-from-string build-outputs read)))
+ ,(with-input-from-string build-outputs read))
+ (#:priority . ,priority))
specs)))))))
(define-enumeration evaluation-status
@@ -622,15 +632,19 @@ string."
;; Extended error codes (see <sqlite3.h>).
;; XXX: This should be defined by (sqlite3).
+(define SQLITE_BUSY 5)
(define SQLITE_CONSTRAINT 19)
(define SQLITE_CONSTRAINT_PRIMARYKEY
(logior SQLITE_CONSTRAINT (ash 6 8)))
(define SQLITE_CONSTRAINT_UNIQUE
(logior SQLITE_CONSTRAINT (ash 8 8)))
+(define SQLITE_BUSY_SNAPSHOT
+ (logior SQLITE_BUSY (ash 2 8)))
(define-enumeration build-status
;; Build status as expected by Hydra's API. Note: the negative values are
;; Cuirass' own extensions.
+ (submitted -3)
(scheduled -2)
(started -1)
(succeeded 0)
@@ -662,7 +676,7 @@ Return #f otherwise. BUILD outputs are stored in the
OUTPUTS table."
(with-db-writer-worker-thread/force db
(sqlite-exec db "
INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log,
-status, timestamp, starttime, stoptime)
+status, priority, max_silent, timeout, timestamp, starttime, stoptime)
VALUES ("
(assq-ref build #:derivation) ", "
(assq-ref build #:eval-id) ", "
@@ -672,9 +686,12 @@ VALUES ("
(assq-ref build #:log) ", "
(or (assq-ref build #:status)
(build-status scheduled)) ", "
- (or (assq-ref build #:timestamp) 0) ", "
- (or (assq-ref build #:starttime) 0) ", "
- (or (assq-ref build #:stoptime) 0) ");")
+ (assq-ref build #:priority) ", "
+ (or (assq-ref build #:max-silent) 0) ", "
+ (or (assq-ref build #:timeout) 0) ", "
+ (or (assq-ref build #:timestamp) 0) ", "
+ (or (assq-ref build #:starttime) 0) ", "
+ (or (assq-ref build #:stoptime) 0) ");")
(let* ((derivation (assq-ref build #:derivation))
(outputs (assq-ref build #:outputs))
(new-outputs (filter-map (cut db-add-output derivation <>)
@@ -702,7 +719,7 @@ path) VALUES ("
(assq-ref product #:path) ");")
(last-insert-rowid db)))
-(define (db-register-builds jobs eval-id)
+(define (db-register-builds jobs eval-id specification)
(define (new-outputs? outputs)
(let ((new-outputs
(filter-map (match-lambda
@@ -712,16 +729,23 @@ path) VALUES ("
outputs)))
(not (null? new-outputs))))
+ (define (build-priority priority)
+ (let ((spec-priority (assq-ref specification #:priority)))
+ (+ (* spec-priority 10) priority)))
+
(define (register job)
- (let* ((name (assq-ref job #:job-name))
- (drv (assq-ref job #:derivation))
- (job-name (assq-ref job #:job-name))
- (system (assq-ref job #:system))
- (nix-name (assq-ref job #:nix-name))
- (log (assq-ref job #:log))
- (period (assq-ref job #:period))
- (outputs (assq-ref job #:outputs))
- (cur-time (time-second (current-time time-utc))))
+ (let* ((name (assq-ref job #:job-name))
+ (drv (assq-ref job #:derivation))
+ (job-name (assq-ref job #:job-name))
+ (system (assq-ref job #:system))
+ (nix-name (assq-ref job #:nix-name))
+ (log (assq-ref job #:log))
+ (period (assq-ref job #:period))
+ (priority (or (assq-ref job #:priority) max-priority))
+ (max-silent (assq-ref job #:max-silent-time))
+ (timeout (assq-ref job #:timeout))
+ (outputs (assq-ref job #:outputs))
+ (cur-time (time-second (current-time time-utc))))
(and (new-outputs? outputs)
(let ((build `((#:derivation . ,drv)
(#:eval-id . ,eval-id)
@@ -734,12 +758,15 @@ path) VALUES ("
(#:log . ,(or log ""))
(#:status . ,(build-status scheduled))
+ (#:priority . ,(build-priority priority))
+ (#:max-silent . ,max-silent)
+ (#:timeout . ,timeout)
(#:outputs . ,outputs)
(#:timestamp . ,cur-time)
(#:starttime . 0)
(#:stoptime . 0))))
(if period
- (let* ((spec (db-get-evaluation-specification eval-id))
+ (let* ((spec (assq-ref specification #:name))
(time
(db-get-time-since-previous-build job-name spec))
(add-build? (cond
@@ -803,10 +830,10 @@ log file for DRV."
(#:event . ,(assq-ref status-names
status)))))))))
-(define* (db-update-build-machine! drv machine)
- "Update the database so that DRV's machine is MACHINE."
+(define* (db-update-build-worker! drv worker)
+ "Update the database so that DRV's worker is WORKER."
(with-db-writer-worker-thread db
- (sqlite-exec db "UPDATE Builds SET machine=" machine
+ (sqlite-exec db "UPDATE Builds SET worker=" worker
"WHERE derivation=" drv ";")))
(define (db-get-output path)
@@ -955,6 +982,8 @@ CASE WHEN :borderlowid IS NULL THEN
;; before those in 'scheduled' state (-2).
(('order . 'status+submission-time)
"Builds.status DESC, Builds.timestamp DESC, Builds.rowid ASC")
+ (('order . 'priority+timestamp)
+ "Builds.priority DESC, Builds.timestamp ASC")
(_ "Builds.rowid DESC"))))
;; XXX: Make sure that all filters are covered by an index.
@@ -965,10 +994,12 @@ CASE WHEN :borderlowid IS NULL THEN
(derivation . "Builds.derivation = :derivation")
(job . "Builds.job_name = :job")
(system . "Builds.system = :system")
+ (worker . "Builds.worker = :worker")
(evaluation . "Builds.evaluation = :evaluation")
(status . ,(match (assq-ref filters 'status)
(#f #f)
('done "Builds.status >= 0")
+ ('scheduled "Builds.status = -2")
('started "Builds.status = -1")
('pending "Builds.status < 0")
('succeeded "Builds.status = 0")
@@ -1031,7 +1062,8 @@ GROUP_CONCAT(Outputs.name), GROUP_CONCAT(Outputs.path),
GROUP_CONCAT(BP.rowid), GROUP_CONCAT(BP.type), GROUP_CONCAT(BP.file_size),
GROUP_CONCAT(BP.checksum), GROUP_CONCAT(BP.path) FROM
(SELECT Builds.derivation, Builds.rowid, Builds.timestamp, Builds.starttime,
- Builds.stoptime, Builds.log, Builds.status, Builds.job_name,
+ Builds.stoptime, Builds.log, Builds.status, Builds.priority,
+ Builds.max_silent, Builds.timeout, Builds.job_name,
Builds.system, Builds.nix_name, Builds.evaluation,
Specifications.name
FROM Builds
@@ -1070,7 +1102,8 @@ ORDER BY ~a;"
(sqlite-fold-right
(lambda (row result)
(match row
- (#(derivation id timestamp starttime stoptime log status
job-name
+ (#(derivation id timestamp starttime stoptime log status
+ priority max-silent timeout job-name
system nix-name eval-id specification
outputs-name outputs-path
products-id products-type products-file-size
@@ -1082,6 +1115,9 @@ ORDER BY ~a;"
(#:stoptime . ,stoptime)
(#:log . ,log)
(#:status . ,status)
+ (#:priority . ,priority)
+ (#:max-silent . ,max-silent)
+ (#:timeout . ,timeout)
(#:job-name . ,job-name)
(#:system . ,system)
(#:nix-name . ,nix-name)
@@ -1413,3 +1449,38 @@ WHERE build = " build-id))
(#:checksum . ,checksum)
(#:path . ,path))
products)))))))
+
+(define (db-add-worker worker)
+ "Insert WORKER into Worker table."
+ (with-db-writer-worker-thread db
+ (sqlite-exec db "\
+INSERT OR REPLACE INTO Workers (name, address, systems, last_seen)
+VALUES ("
+ (worker-name worker) ", "
+ (worker-address worker) ", "
+ (string-join (worker-systems worker) ",") ", "
+ (worker-last-seen worker) ");")
+ (last-insert-rowid db)))
+
+(define (db-get-workers)
+ "Return the workers in Workers table."
+ (with-db-worker-thread db
+ (let loop ((rows (sqlite-exec db "
+SELECT name, address, systems, last_seen from Workers"))
+ (workers '()))
+ (match rows
+ (() (reverse workers))
+ ((#(name address systems last-seen)
+ . rest)
+ (loop rest
+ (cons (worker
+ (name name)
+ (address address)
+ (systems (string-split systems #\,))
+ (last-seen last-seen))
+ workers)))))))
+
+(define (db-clear-workers)
+ "Remove all workers from Workers table."
+ (with-db-writer-worker-thread db
+ (sqlite-exec db "DELETE FROM Workers;")))
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 99dc2ce..3ac7ef9 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -28,6 +28,7 @@
#:use-module (cuirass metrics)
#:use-module (cuirass utils)
#:use-module (cuirass logging)
+ #:use-module (cuirass remote)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@@ -446,26 +447,11 @@ Hydra format."
(#:link . ,(string-append "/jobset/" (assq-ref build
#:specification)))))))
(respond-build-not-found id))))
(('GET "build" (= string->number id) "log" "raw")
- (let ((build (and id (db-get-build id))))
- (if build
- (match (assq-ref build #:outputs)
- (((_ (#:path . (? string? output))) _ ...)
- ;; Redirect to a /log URL, which is assumed to be served
- ;; by 'guix publish'.
- (let ((uri (string->uri-reference
- (string-append "/log/"
- (basename output)))))
- (respond (build-response #:code 302
- #:headers `((location . ,uri)))
- #:body "")))
- (()
- ;; Not entry for ID in the 'Outputs' table.
- (respond-json-with-error
- 500
- (format #f "Outputs of build ~a are unknown." id)))
- (#f
- (respond-build-not-found id)))
- (respond-build-not-found id))))
+ (let* ((build (and id (db-get-build id)))
+ (log (and build (assq-ref build #:log))))
+ (if (and log (file-exists? log))
+ (respond-gzipped-file log)
+ (respond-not-found (uri->string (request-uri request))))))
(('GET "output" id)
(let ((output (db-get-output
(string-append (%store-prefix) "/" id))))
@@ -661,6 +647,21 @@ Hydra format."
(respond-json-with-error 500 "No build found.")))
(respond-json-with-error 500 "Query parameter not provided."))))
+ (('GET "workers")
+ (respond-html
+ (html-page
+ "Workers status"
+ (let ((workers (db-get-workers)))
+ (workers-status
+ workers
+ (map (lambda (worker)
+ (let ((name (worker-name worker)))
+ (db-get-builds `((worker . ,name)
+ (status . started)
+ (order . status+submission-time)))))
+ workers)))
+ '())))
+
(('GET "metrics")
(respond-html
(metrics-page)))
diff --git a/src/cuirass/metrics.scm b/src/cuirass/metrics.scm
index cd6a066..9a0fd14 100644
--- a/src/cuirass/metrics.scm
+++ b/src/cuirass/metrics.scm
@@ -329,42 +329,44 @@ timestamp) VALUES ("
(define (db-update-metrics)
"Compute and update all available metrics in database."
(with-db-writer-worker-thread/force db
- ;; We can not update all evaluations metrics for performance reasons.
- ;; Limit to the evaluations that were added during the past three days.
- (let ((specifications
- (map (cut assq-ref <> #:name) (db-get-specifications)))
- (evaluations (db-latest-evaluations)))
- (sqlite-exec db "BEGIN TRANSACTION;")
-
- (db-update-metric 'builds-per-day)
- (db-update-metric 'new-derivations-per-day)
- (db-update-metric 'pending-builds)
-
- ;; Update specification related metrics.
- (for-each (lambda (spec)
- (db-update-metric
- 'average-10-last-eval-duration-per-spec spec)
- (db-update-metric
- 'average-100-last-eval-duration-per-spec spec)
- (db-update-metric
- 'average-eval-duration-per-spec spec)
-
- (db-update-metric
- 'percentage-failure-10-last-eval-per-spec spec)
- (db-update-metric
- 'percentage-failure-100-last-eval-per-spec spec)
- (db-update-metric
- 'percentage-failed-eval-per-spec spec))
- specifications)
-
- ;; Update evaluation related metrics.
- (for-each (lambda (evaluation)
- (db-update-metric
- 'average-eval-build-start-time evaluation)
- (db-update-metric
- 'average-eval-build-complete-time evaluation)
- (db-update-metric
- 'evaluation-completion-speed evaluation))
- evaluations)
-
- (sqlite-exec db "COMMIT;"))))
+ (catch-sqlite-error
+ ;; We can not update all evaluations metrics for performance reasons.
+ ;; Limit to the evaluations that were added during the past three days.
+ (let ((specifications
+ (map (cut assq-ref <> #:name) (db-get-specifications)))
+ (evaluations (db-latest-evaluations)))
+ (sqlite-exec db "BEGIN TRANSACTION;")
+
+ (db-update-metric 'builds-per-day)
+ (db-update-metric 'new-derivations-per-day)
+ (db-update-metric 'pending-builds)
+
+ ;; Update specification related metrics.
+ (for-each (lambda (spec)
+ (db-update-metric
+ 'average-10-last-eval-duration-per-spec spec)
+ (db-update-metric
+ 'average-100-last-eval-duration-per-spec spec)
+ (db-update-metric
+ 'average-eval-duration-per-spec spec)
+
+ (db-update-metric
+ 'percentage-failure-10-last-eval-per-spec spec)
+ (db-update-metric
+ 'percentage-failure-100-last-eval-per-spec spec)
+ (db-update-metric
+ 'percentage-failed-eval-per-spec spec))
+ specifications)
+
+ ;; Update evaluation related metrics.
+ (for-each (lambda (evaluation)
+ (db-update-metric
+ 'average-eval-build-start-time evaluation)
+ (db-update-metric
+ 'average-eval-build-complete-time evaluation)
+ (db-update-metric
+ 'evaluation-completion-speed evaluation))
+ evaluations)
+
+ (sqlite-exec db "COMMIT;"))
+ (on SQLITE_BUSY_SNAPSHOT => #f))))
diff --git a/src/cuirass/remote-server.scm b/src/cuirass/remote-server.scm
new file mode 100644
index 0000000..70c1504
--- /dev/null
+++ b/src/cuirass/remote-server.scm
@@ -0,0 +1,594 @@
+;;; remote-server.scm -- Remote build server.
+;;; Copyright © 2020 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 remote-server)
+ #:use-module (cuirass base)
+ #:use-module (cuirass database)
+ #:use-module (cuirass logging)
+ #:use-module (cuirass remote)
+ #:use-module (cuirass utils)
+ #:use-module (gcrypt pk-crypto)
+ #:use-module (guix avahi)
+ #:use-module (guix base32)
+ #:use-module (guix base64)
+ #:use-module (guix config)
+ #:use-module (guix derivations)
+ #:use-module (guix records)
+ #:use-module (guix packages)
+ #:use-module (guix pki)
+ #:use-module (guix scripts)
+ #:use-module ((guix store) #:select (ensure-path with-store))
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix workers)
+ #:use-module (guix build download)
+ #:use-module (guix build syscalls)
+ #:use-module ((guix build utils) #:select (mkdir-p))
+ #:use-module (gcrypt hash)
+ #:use-module (gcrypt pk-crypto)
+ #:use-module (simple-zmq)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 atomic)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 q)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 threads)
+
+ #:export (remote-server))
+
+;; Indicate if the process has to be stopped.
+(define %stop-process?
+ (make-atomic-box #f))
+
+;; Whether to add build items to the store.
+(define %add-to-store?
+ (make-parameter #f))
+
+(define %cache-directory
+ (make-parameter #f))
+
+(define %log-directory
+ (make-parameter #f))
+
+(define %private-key
+ (make-parameter #f))
+
+(define %public-key
+ (make-parameter #f))
+
+(define service-name
+ "Cuirass remote server")
+
+(define (show-help)
+ (format #t (G_ "Usage: remote-server [OPTION]...
+Start a remote build server.\n"))
+ (display (G_ "
+ -a, --add-to-store register built items to the store"))
+ (display (G_ "
+ -b, --backend-port=PORT listen worker connections on PORT"))
+ (display (G_ "
+ -p, --publish-port=PORT publish substitutes on PORT"))
+ (display (G_ "
+ -D, --database=DB Use DB to read and store build results"))
+ (display (G_ "
+ -c, --cache=DIRECTORY cache built items to DIRECTORY"))
+ (display (G_ "
+ -l, --log-directory=DIRECTORY cache log files to DIRECTORY"))
+ (display (G_ "
+ -u, --user=USER change privileges to USER as soon as possible"))
+ (display (G_ "
+ --public-key=FILE use FILE as the public key for signatures"))
+ (display (G_ "
+ --private-key=FILE use FILE as the private key for signatures"))
+ (newline)
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ (list (option '(#\h "help") #f #f
+ (lambda _
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda _
+ (show-version-and-exit "guix publish")))
+ (option '(#\a "add-to-store") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'add-to-store? arg result)))
+ (option '(#\b "backend-port") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'backend-port (string->number* arg) result)))
+ (option '(#\p "publish-port") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'publish-port (string->number* arg) result)))
+ (option '(#\D "database") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'database arg result)))
+ (option '(#\c "cache") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cache arg result)))
+ (option '(#\l "log-directory") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'log-directory arg result)))
+ (option '(#\u "user") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'user arg result)))
+ (option '("public-key") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'public-key-file arg result)))
+ (option '("private-key") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'private-key-file arg result)))))
+
+(define %default-options
+ `((backend-port . 5555)
+ (publish-port . 5556)
+ (public-key-file . ,%public-key-file)
+ (private-key-file . ,%private-key-file)))
+
+
+;;;
+;;; Build workers.
+;;;
+
+(define %workers
+ ;; Set of connected workers.
+ (make-hash-table))
+
+(define (pop-build name)
+ (define (random-system systems)
+ (list-ref systems (random (length systems))))
+
+ (let ((worker (hash-ref %workers name)))
+ (and worker
+ (let ((system (random-system
+ (worker-systems worker))))
+ (match (db-get-builds `((status . scheduled)
+ (system . ,system)
+ (order . priority+timestamp)
+ (nr . 1)))
+ ((build) build)
+ (() #f))))))
+
+(define (remove-unresponsive-workers!)
+ (let ((unresponsive
+ (hash-fold (lambda (key value old)
+ (let* ((last-seen (worker-last-seen value))
+ (diff (- (current-time) last-seen)))
+ (if (> diff (%worker-timeout))
+ (cons key old)
+ old)))
+ '()
+ %workers)))
+ (for-each (lambda (worker)
+ (hash-remove! %workers worker))
+ unresponsive)))
+
+(define* (read-worker-exp exp #:key reply-worker)
+ "Read the given EXP sent by a worker. REPLY-WORKER is a procedure that can
+be used to reply to the worker."
+ (define (update-workers! base-worker proc)
+ (let* ((worker* (worker
+ (inherit (sexp->worker base-worker))
+ (last-seen (current-time))))
+ (name (worker-name worker*)))
+ (proc name)
+ (hash-set! %workers name worker*)))
+
+ (match (zmq-read-message exp)
+ (('worker-ready worker)
+ (update-workers! worker
+ (lambda (name)
+ (info (G_ "Worker `~a' is ready.~%") name))))
+ (('worker-request-work name)
+ (let ((build (pop-build name)))
+ (if build
+ (let ((derivation (assq-ref build #:derivation))
+ (priority (assq-ref build #:priority))
+ (timeout (assq-ref build #:timeout))
+ (max-silent (assq-ref build #:max-silent)))
+ (db-update-build-status! derivation (build-status submitted))
+ (reply-worker
+ (zmq-build-request-message derivation
+ #:priority priority
+ #:timeout timeout
+ #:max-silent max-silent))))
+ (reply-worker
+ (zmq-no-build-message))))
+ (('worker-ping worker)
+ (update-workers! worker (const #t))
+ (db-clear-workers)
+ (hash-for-each (lambda (key value)
+ (db-add-worker value))
+ %workers))
+ (('build-started ('drv drv) ('worker worker))
+ (log-message "build started: '~a' on ~a." drv worker)
+ (db-update-build-worker! drv worker)
+ (db-update-build-status! drv (build-status started)))))
+
+
+;;;
+;;; Fetch workers.
+;;;
+
+(define %default-compression
+ "gzip")
+
+(define (zmq-fetch-workers-endpoint)
+ "inproc://fetch-workers")
+
+(define (zmq-fetch-worker-socket)
+ "Return a socket used to communicate with the fetch workers."
+ (let ((socket (zmq-create-socket %zmq-context ZMQ_PULL))
+ (endpoint (zmq-fetch-workers-endpoint)))
+ (zmq-connect socket endpoint)
+ socket))
+
+(define (strip-store-prefix file)
+ ; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
+ ;; "/bin/foo".
+ (let* ((len (string-length %store-directory))
+ (base (string-drop file (+ 1 len))))
+ (match (string-index base #\/)
+ (#f base)
+ (index (string-drop base index)))))
+
+(define (publish-nar-url publish-url store-hash)
+ "Return the URL of STORE-HASH nar substitute on PUBLISH-URL."
+ (format #f "~a/nar/~a/~a" publish-url %default-compression store-hash))
+
+(define (publish-narinfo-url publish-url store-hash)
+ "Return the URL of STORE-HASH narinfo file on PUBLISH-URL."
+ (let ((hash (and=> (string-index store-hash #\-)
+ (cut string-take store-hash <>))))
+ (format #f "~a/~a.narinfo" publish-url hash)))
+
+(define (nar-path cache-directory output)
+ "Return the path of the NAR file for OUTPUT in CACHE-DIRECTORY."
+ (string-append cache-directory "/"
+ %default-compression
+ "/" (basename output) ".nar"))
+
+(define (narinfo-path cache-directory output)
+ "Return the path of the NARINFO file for OUTPUT in CACHE-DIRECTORY."
+ (string-append cache-directory "/"
+ %default-compression
+ "/" (basename output) ".narinfo"))
+
+(define (hash-path cache-directory store-hash)
+ (let ((hash (and=> (string-index store-hash #\-)
+ (cut string-take store-hash <>))))
+ (string-append cache-directory "/hashes/" hash)))
+
+(define (write-hash cache-directory hash-file path)
+ (with-atomic-file-output hash-file
+ (lambda (port)
+ (display path port))))
+
+(define (log-path cache-directory output)
+ (string-append cache-directory "/" (basename output) ".log"))
+
+(define* (sign-narinfo! narinfo)
+ "Edit the given NARINFO file to replace the worker signature by the remote
+build server signature."
+ (define (signed-string s)
+ (let* ((hash (bytevector->hash-data (sha256 (string->utf8 s))
+ #:key-type (key-type (%public-key)))))
+ (signature-sexp hash (%private-key) (%public-key))))
+
+ (define base64-encode-string
+ (compose base64-encode string->utf8))
+
+ (define lines
+ (call-with-input-file narinfo
+ (lambda (port)
+ (let loop ((line (read-line port))
+ (lines '()))
+ (if (eof-object? line)
+ (reverse lines)
+ (loop (read-line port)
+ (cons line lines)))))))
+ (let* ((lines
+ (filter (lambda (line)
+ (not (string-match "^Signature:" line)))
+ lines))
+ (info (format #f "~a~%" (string-join lines "\n")))
+ (signature (base64-encode-string
+ (canonical-sexp->string (signed-string info)))))
+ (call-with-output-file narinfo
+ (lambda (port)
+ (format port "~aSignature: 1;~a;~a~%"
+ info (gethostname) signature)))))
+
+(define (url-fetch* url file)
+ (parameterize ((current-output-port (%make-void-port "w"))
+ (current-error-port (%make-void-port "w")))
+ (url-fetch url file)))
+
+(define (download-nar cache-directory outputs url)
+ "Download in CACHE-DIRECTORY the OUTPUTS from the substitute server at URL."
+ (for-each
+ (lambda (output)
+ (let* ((path (derivation-output-path output))
+ (store-hash (strip-store-prefix path))
+ (hash-file (hash-path cache-directory store-hash))
+ (nar-file (nar-path cache-directory store-hash))
+ (narinfo-file (narinfo-path cache-directory store-hash))
+ (nar-url (publish-nar-url url store-hash))
+ (narinfo-url (publish-narinfo-url url store-hash)))
+
+ (unless (file-exists? nar-file)
+ (mkdir-p (dirname nar-file))
+ (or (url-fetch* nar-url nar-file)
+ (warning (G_ "Failed to download ~a~%.") nar-url)))
+
+ (unless (file-exists? narinfo-file)
+ (or (and (url-fetch* narinfo-url narinfo-file)
+ (sign-narinfo! narinfo-file))
+ (warning (G_ "Failed to download ~a~%.") narinfo-url)))
+
+ (unless (file-exists? hash-file)
+ (mkdir-p (dirname hash-file))
+ (write-hash cache-directory hash-file path)
+ (chmod hash-file #o644))))
+ outputs))
+
+(define (download-log-file cache-directory derivation url)
+ (let ((url (string-append url "/log/" (basename derivation)))
+ (log-file (log-path cache-directory derivation)))
+ (url-fetch* url log-file)))
+
+(define (add-to-store outputs url)
+ "Add the OUTPUTS that are available from the substitute server at URL to the
+store."
+ (with-store store
+ (for-each (lambda (output)
+ (set-build-options* store url)
+ (ensure-path store output))
+ (map derivation-output-path outputs))))
+
+(define (need-fetching? message)
+ "Return #t if the received MESSAGE implies that some output fetching is
+required and #f otherwise."
+ (match (zmq-read-message message)
+ (('build-succeeded _ ...)
+ #t)
+ (('build-failed _ ...)
+ #t)
+ (else #f)))
+
+(define* (run-fetch message)
+ "Read MESSAGE and download the corresponding build outputs. If
+%CACHE-DIRECTORY is set, download the matching NAR and NARINFO files in this
+directory. If %ADD-TO-STORE? is set, add the build outputs to the store."
+ (define (build-outputs drv)
+ (catch 'system-error
+ (lambda ()
+ (map (match-lambda
+ ((output-name . output)
+ output))
+ (derivation-outputs
+ (read-derivation-from-file drv))))
+ (const '())))
+
+ (let ((log-directory (%log-directory)))
+ (match (zmq-read-message message)
+ (('build-succeeded ('drv drv) ('url url) _ ...)
+ (let ((outputs (build-outputs drv))
+ (log-file
+ (and log-directory
+ (download-log-file log-directory drv url))))
+ (when (%add-to-store?)
+ (add-to-store outputs url))
+ (when (%cache-directory)
+ (download-nar (%cache-directory) outputs url))
+ (log-message "build succeeded: '~a'" drv)
+ (set-build-successful! drv log-file)))
+ (('build-failed ('drv drv) ('url url) _ ...)
+ (let ((log-file
+ (and log-directory
+ (download-log-file log-directory drv url))))
+ (log-message "build failed: '~a'" drv)
+ (db-update-build-status! drv
+ (if log-file
+ (build-status failed)
+ (build-status failed-dependency))
+ #:log-file log-file))))))
+
+(define (start-fetch-worker name)
+ "Start a fetch worker thread with the given NAME. This worker takes care of
+downloading build outputs. It communicates with the remote server using a ZMQ
+socket."
+ (call-with-new-thread
+ (lambda ()
+ (set-thread-name name)
+ (let ((socket (zmq-fetch-worker-socket)))
+ (let loop ()
+ (match (zmq-get-msg-parts-bytevector socket)
+ ((message)
+ (run-fetch (bv->string message))))
+ (loop))))))
+
+
+;;;
+;;; ZMQ connection.
+;;;
+
+(define %zmq-context
+ (zmq-create-context))
+
+(define (zmq-backend-endpoint backend-port)
+ "Return a ZMQ endpoint string allowing TCP connections on BACKEND-PORT from
+all network interfaces."
+ (string-append "tcp://*:" (number->string backend-port)))
+
+(define (zmq-start-proxy backend-port)
+ "This procedure starts a proxy between client connections from the IPC
+frontend to the workers connected through the TCP backend."
+ (define (socket-ready? items socket)
+ (find (lambda (item)
+ (eq? (poll-item-socket item) socket))
+ items))
+
+ (let* ((build-socket
+ (zmq-create-socket %zmq-context ZMQ_ROUTER))
+ (fetch-socket
+ (zmq-create-socket %zmq-context ZMQ_PUSH))
+ (poll-items (list
+ (poll-item build-socket ZMQ_POLLIN))))
+
+ (zmq-bind-socket build-socket (zmq-backend-endpoint backend-port))
+ (zmq-bind-socket fetch-socket (zmq-fetch-workers-endpoint))
+
+ ;; Do not use the built-in zmq-proxy as we want to edit the envelope of
+ ;; frontend messages before forwarding them to the backend.
+ (let loop ()
+ (let ((items (zmq-poll* poll-items 1000)))
+ (when (zmq-socket-ready? items build-socket)
+ (match (zmq-get-msg-parts-bytevector build-socket)
+ ((worker empty rest)
+ (let ((reply-worker
+ (lambda (message)
+ (zmq-send-msg-parts-bytevector
+ build-socket
+ (list worker
+ (zmq-empty-delimiter)
+ (string->bv message))))))
+ (if (need-fetching? (bv->string rest))
+ (zmq-send-bytevector fetch-socket rest)
+ (read-worker-exp (bv->string rest)
+ #:reply-worker reply-worker))))))
+ (remove-unresponsive-workers!)
+ (loop)))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+;; The PID of the publish process.
+(define %publish-pid
+ (make-atomic-box #f))
+
+;; The thread running the Avahi publish service.
+(define %avahi-thread
+ (make-atomic-box #f))
+
+(define (signal-handler)
+ "Catch SIGINT to stop the Avahi event loop and the publish process before
+exiting."
+ (sigaction SIGINT
+ (lambda (signum)
+ (let ((publish-pid (atomic-box-ref %publish-pid))
+ (avahi-thread (atomic-box-ref %avahi-thread)))
+ (atomic-box-set! %stop-process? #t)
+
+ (and publish-pid
+ (begin
+ (kill publish-pid SIGHUP)
+ (waitpid publish-pid)))
+
+ (and avahi-thread
+ (join-thread avahi-thread))
+
+ (exit 1)))))
+
+(define (gather-user-privileges user)
+ "switch to the identity of user, a user name."
+ (catch 'misc-error
+ (lambda ()
+ (let ((user (getpw user)))
+ (setgroups #())
+ (setgid (passwd:gid user))
+ (setuid (passwd:uid user))))
+ (lambda (key proc message args . rest)
+ (leave (G_ "user '~a' not found: ~a~%")
+ user (apply format #f message args)))))
+
+(define (init-database)
+ (%db-channel (make-worker-thread-channel
+ (lambda ()
+ (list (db-open)))
+ #:parallelism 1))
+ (%db-writer-channel (%db-channel)))
+
+(define (remote-server args)
+ (signal-handler)
+
+ (with-error-handling
+ (let* ((opts (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (G_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (leave (G_ "~A: extraneous argument~%") arg))
+ %default-options))
+ (add-to-store? (assoc-ref opts 'add-to-store?))
+ (backend-port (assoc-ref opts 'backend-port))
+ (publish-port (assoc-ref opts 'publish-port))
+ (cache (assoc-ref opts 'cache))
+ (database (assoc-ref opts 'database))
+ (log-directory (assoc-ref opts 'log-directory))
+ (user (assoc-ref opts 'user))
+ (public-key
+ (read-file-sexp
+ (assoc-ref opts 'public-key-file)))
+ (private-key
+ (read-file-sexp
+ (assoc-ref opts 'private-key-file))))
+
+ (parameterize ((%add-to-store? add-to-store?)
+ (%cache-directory cache)
+ (%log-directory log-directory)
+ (%package-database database)
+ (%public-key public-key)
+ (%private-key private-key))
+ (when user
+ (gather-user-privileges user))
+
+ (atomic-box-set!
+ %publish-pid
+ (publish-server publish-port
+ #:public-key public-key
+ #:private-key private-key))
+
+ (atomic-box-set!
+ %avahi-thread
+ (avahi-publish-service-thread
+ service-name
+ #:type remote-server-service-type
+ #:port backend-port
+ #:stop-loop? (lambda ()
+ (atomic-box-ref %stop-process?))
+ #:txt (list (string-append "publish="
+ (number->string publish-port)))))
+ (init-database)
+ (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/cuirass/remote-worker.scm b/src/cuirass/remote-worker.scm
new file mode 100644
index 0000000..baee0e4
--- /dev/null
+++ b/src/cuirass/remote-worker.scm
@@ -0,0 +1,370 @@
+;;; remote-worker.scm -- Remote build worker.
+;;; Copyright © 2020 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 remote-worker)
+ #:use-module (cuirass remote)
+ #:use-module (gcrypt pk-crypto)
+ #:use-module (guix avahi)
+ #:use-module (guix config)
+ #:use-module (guix derivations)
+ #:use-module (guix diagnostics)
+ #:use-module (guix pki)
+ #:use-module (guix records)
+ #:use-module (guix scripts)
+ #:use-module ((guix store)
+ #:select (current-build-output-port
+ store-error?
+ store-protocol-error?
+ store-protocol-error-message
+ with-store))
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix build syscalls)
+ #:use-module (guix build utils)
+ #:use-module (guix scripts publish)
+ #:use-module (simple-zmq)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 atomic)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 threads)
+
+ #:export (remote-worker))
+
+;; Indicate if the process has to be stopped.
+(define %stop-process?
+ (make-atomic-box #f))
+
+(define (show-help)
+ (format #t (G_ "Usage: remote-worker [OPTION]...
+Start a remote build worker.\n"))
+ (display (G_ "
+ -w, --workers=COUNT start COUNT parallel workers"))
+ (display (G_ "
+ -p, --publish-port=PORT publish substitutes on PORT"))
+ (display (G_ "
+ -S, --server=SERVER connect to SERVER"))
+ (display (G_ "
+ -s, --systems=SYSTEMS list of supported SYSTEMS"))
+ (display (G_ "
+ --public-key=FILE use FILE as the public key for signatures"))
+ (display (G_ "
+ --private-key=FILE use FILE as the private key for signatures"))
+ (newline)
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ (list (option '(#\h "help") #f #f
+ (lambda _
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda _
+ (show-version-and-exit "guix publish")))
+ (option '(#\a "address") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'address arg result)))
+ (option '(#\w "workers") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'workers (string->number* arg) result)))
+ (option '(#\p "publish-port") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'publish-port (string->number* arg) result)))
+ (option '(#\s "server") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'server arg result)))
+ (option '(#\S "systems") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'systems
+ (string-split arg #\,) result)))
+ (option '("public-key") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'public-key-file arg result)))
+ (option '("private-key") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'private-key-file arg result)))))
+
+(define %default-options
+ `((workers . 1)
+ (publish-port . 5558)
+ (systems . ,(list (%current-system)))
+ (public-key-file . ,%public-key-file)
+ (private-key-file . ,%private-key-file)))
+
+
+;;;
+;;; ZMQ connection.
+;;;
+
+(define %zmq-context
+ (zmq-create-context))
+
+(define (zmq-backend-endpoint address port)
+ "Return a ZMQ endpoint identifying the build server available by TCP at
+ADDRESS and PORT."
+ (string-append "tcp://" address ":" (number->string port)))
+
+(define (zmq-dealer-socket)
+ "The ZMQ socket to communicate with the worker threads."
+ (zmq-create-socket %zmq-context ZMQ_DEALER))
+
+
+;;;
+;;; Worker.
+;;;
+
+;; The port of the local publish server.
+(define %local-publish-port
+ (make-atomic-box #f))
+
+(define (local-publish-url address)
+ "Return the URL of the local publish server."
+ (let ((port (atomic-box-ref %local-publish-port)))
+ (publish-url address port)))
+
+(define (empty-cache!)
+ (let ((cache "/var/guix/substitute/cache"))
+ (when (file-exists? cache)
+ (parameterize ((current-error-port (%make-void-port "w")))
+ (false-if-exception
+ (delete-file-recursively cache))))))
+
+(define* (run-build drv server
+ #:key
+ reply
+ timeout
+ max-silent
+ worker)
+ "Build DRV and send messages upon build start, failure or completion to the
+build server identified by SERVICE-NAME using the REPLY procedure.
+
+The publish server of the build server is added to the list of the store
+substitutes-urls. This way derivations that are not present on the worker can
+still be substituted."
+ (parameterize ((current-build-output-port (%make-void-port "w")))
+ (with-store store
+ (let ((publish-url (server-publish-url server))
+ (local-publish-url (worker-publish-url worker))
+ (name (worker-name worker)))
+ (set-build-options* store publish-url
+ #:timeout timeout
+ #:max-silent max-silent)
+ (empty-cache!)
+ (reply (zmq-build-started-message drv name))
+ (guard (c ((store-error? c)
+ (info (G_ "Derivation `~a' build failed.~%") drv)
+ (reply (zmq-build-failed-message drv local-publish-url)))
+ ((store-protocol-error? c)
+ (info (G_ "Derivation `~a' build failed: ~a~%")
+ drv (store-protocol-error-message c))
+ (reply (zmq-build-failed-message drv local-publish-url))))
+ (if (build-derivations store (list drv))
+ (begin
+ (info (G_ "Derivation ~a build succeeded.~%") drv)
+ (reply (zmq-build-succeeded-message drv local-publish-url)))
+ (begin
+ (info (G_ "Derivation ~a build failed.~%") drv)
+ (reply
+ (zmq-build-failed-message drv local-publish-url)))))))))
+
+(define* (run-command command server
+ #:key
+ reply worker)
+ "Run COMMAND. SERVICE-NAME is the name of the build server that sent the
+command. REPLY is a procedure that can be used to reply to this server."
+ (match (zmq-read-message command)
+ (('build ('drv drv)
+ ('priority priority)
+ ('timeout timeout)
+ ('max-silent max-silent)
+ ('timestamp timestamp)
+ ('system system))
+ (info (G_ "Building `~a' derivation.~%") drv)
+ (run-build drv server
+ #:reply reply
+ #:worker worker
+ #:timeout timeout
+ #:max-silent max-silent))
+ (('no-build)
+ #t)))
+
+(define (worker-ping worker server)
+ (define (ping socket)
+ (zmq-send-msg-parts-bytevector
+ socket
+ (list (make-bytevector 0)
+ (string->bv
+ (zmq-worker-ping (worker->sexp worker))))))
+
+ (call-with-new-thread
+ (lambda ()
+ (let* ((socket (zmq-dealer-socket))
+ (address (server-address server))
+ (port (server-port server))
+ (endpoint (zmq-backend-endpoint address port)))
+ (zmq-connect socket endpoint)
+ (let loop ()
+ (ping socket)
+ (sleep 60)
+ (loop))))))
+
+(define (start-worker worker server)
+ "Start a worker thread named NAME, reading commands from the DEALER socket
+and executing them. The worker can reply on the same socket."
+ (define (reply socket)
+ (lambda (message)
+ (zmq-send-msg-parts-bytevector
+ socket
+ (list (zmq-empty-delimiter) (string->bv message)))))
+
+ (define (ready socket)
+ (zmq-send-msg-parts-bytevector
+ socket
+ (list (make-bytevector 0)
+ (string->bv
+ (zmq-worker-ready-message (worker->sexp worker))))))
+
+ (define (request-work socket)
+ (let ((name (worker-name worker)))
+ (zmq-send-msg-parts-bytevector
+ socket
+ (list (make-bytevector 0)
+ (string->bv (zmq-worker-request-work-message name))))))
+
+ (call-with-new-thread
+ (lambda ()
+ (set-thread-name (worker-name worker))
+ (let* ((socket (zmq-dealer-socket))
+ (address (server-address server))
+ (port (server-port server))
+ (endpoint (zmq-backend-endpoint address port)))
+ (zmq-connect socket endpoint)
+ (ready socket)
+ (worker-ping worker server)
+ (let loop ()
+ (request-work socket)
+ (match (zmq-get-msg-parts-bytevector socket '())
+ ((empty command)
+ (run-command (bv->string command) server
+ #:reply (reply socket)
+ #:worker worker)))
+ (sleep 10)
+ (loop))))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+;; The PID of the publish process.
+(define %publish-pid
+ (make-atomic-box #f))
+
+(define (load-server file)
+ (let ((user-module (make-user-module '((cuirass remote)))))
+ (load* file user-module)))
+
+(define (signal-handler)
+ "Catch SIGINT to stop the Avahi event loop and the publish process before
+exiting."
+ (sigaction SIGINT
+ (lambda (signum)
+ (let ((publish-pid (atomic-box-ref %publish-pid)))
+ (atomic-box-set! %stop-process? #t)
+
+ (and publish-pid
+ (begin
+ (kill publish-pid SIGKILL)
+ (waitpid publish-pid)))
+
+ (exit 1)))))
+
+(define (remote-worker args)
+ (signal-handler)
+
+ (with-error-handling
+ (let* ((opts (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (G_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (leave (G_ "~A: extraneous argument~%") arg))
+ %default-options))
+ (address (assoc-ref opts 'address))
+ (workers (assoc-ref opts 'workers))
+ (publish-port (assoc-ref opts 'publish-port))
+ (server (assoc-ref opts 'server))
+ (systems (assoc-ref opts 'systems))
+ (public-key
+ (read-file-sexp
+ (assoc-ref opts 'public-key-file)))
+ (private-key
+ (read-file-sexp
+ (assoc-ref opts 'private-key-file))))
+
+ (atomic-box-set! %local-publish-port publish-port)
+
+ (atomic-box-set!
+ %publish-pid
+ (publish-server publish-port
+ #:public-key public-key
+ #:private-key private-key))
+
+ (when (and server (not address))
+ (leave (G_ "Address must be set when server is provided.~%")))
+
+ (if server
+ (let ((server (load-server server)))
+ (for-each
+ (lambda (n)
+ (let ((publish-url (local-publish-url address)))
+ (start-worker (worker
+ (address address)
+ (publish-url publish-url)
+ (name (generate-worker-name))
+ (systems systems))
+ server)))
+ (iota workers))
+ (while #t
+ (sleep 1)))
+ (avahi-browse-service-thread
+ (lambda (action service)
+ (case action
+ ((new-service)
+ (for-each
+ (lambda (n)
+ (let ((address (or address
+ (avahi-service-local-address service)))
+ (publish-url (local-publish-url address)))
+ (start-worker (worker
+ (address address)
+ (publish-url publish-url)
+ (name (generate-worker-name))
+ (systems systems))
+ (avahi-service->server service))))
+ (iota workers)))))
+ #:types (list remote-server-service-type)
+ #:stop-loop? (lambda ()
+ (atomic-box-ref %stop-process?)))))))
diff --git a/src/cuirass/remote.scm b/src/cuirass/remote.scm
new file mode 100644
index 0000000..690cac9
--- /dev/null
+++ b/src/cuirass/remote.scm
@@ -0,0 +1,331 @@
+;;; remote.scm -- Build on remote machines.
+;;; Copyright © 2020 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 remote)
+ #:use-module (guix avahi)
+ #:use-module (guix config)
+ #:use-module (guix derivations)
+ #:use-module (guix records)
+ #:use-module (guix store)
+ #:use-module (guix ui)
+ #:use-module (guix build download)
+ #:use-module ((guix build utils) #:select (mkdir-p))
+ #:use-module (guix scripts publish)
+ #:use-module (simple-zmq)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 threads)
+ #:export (worker
+ worker?
+ worker-address
+ worker-name
+ worker-publish-url
+ worker-systems
+ worker-last-seen
+ worker->sexp
+ sexp->worker
+ generate-worker-name
+ %worker-timeout
+
+ server
+ server?
+ server-address
+ server-port
+ server-publish-url
+ publish-url
+ avahi-service->server
+
+ publish-server
+ set-build-options*
+
+ zmq-poll*
+ zmq-socket-ready?
+ zmq-empty-delimiter
+
+ zmq-build-request-message
+ zmq-no-build-message
+ zmq-build-started-message
+ zmq-build-failed-message
+ zmq-build-succeeded-message
+ zmq-worker-ping
+ zmq-worker-ready-message
+ zmq-worker-request-work-message
+ zmq-read-message
+
+ remote-server-service-type))
+
+
+;;;
+;;; Workers.
+;;;
+
+(define-record-type* <worker>
+ worker make-worker
+ worker?
+ (address worker-address)
+ (name worker-name)
+ (publish-url worker-publish-url
+ (default #f))
+ (systems worker-systems)
+ (last-seen worker-last-seen
+ (default 0)))
+
+(define (worker->sexp worker)
+ "Return an sexp describing WORKER."
+ (let ((address (worker-address worker))
+ (name (worker-name worker))
+ (systems (worker-systems worker))
+ (last-seen (worker-last-seen worker)))
+ `(worker
+ (address ,address)
+ (name ,name)
+ (systems ,systems)
+ (last-seen ,last-seen))))
+
+(define (sexp->worker sexp)
+ "Turn SEXP, an sexp as returned by 'worker->sexp', into a <worker> record."
+ (match sexp
+ (('worker ('address address)
+ ('name name)
+ ('systems systems)
+ ('last-seen last-seen))
+ (worker
+ (address address)
+ (name name)
+ (systems systems)
+ (last-seen last-seen)))))
+
+(define %seed
+ (seed->random-state
+ (logxor (getpid) (car (gettimeofday)))))
+
+(define (integer->alphanumeric-char n)
+ "Map N, an integer in the [0..62] range, to an alphanumeric character."
+ (cond ((< n 10)
+ (integer->char (+ (char->integer #\0) n)))
+ ((< n 36)
+ (integer->char (+ (char->integer #\A) (- n 10))))
+ ((< n 62)
+ (integer->char (+ (char->integer #\a) (- n 36))))
+ (else
+ (error "integer out of bounds" n))))
+
+(define (random-string len)
+ "Compute a random string of size LEN where each character is alphanumeric."
+ (let loop ((chars '())
+ (len len))
+ (if (zero? len)
+ (list->string chars)
+ (let ((n (random 62 %seed)))
+ (loop (cons (integer->alphanumeric-char n) chars)
+ (- len 1))))))
+
+(define (generate-worker-name)
+ "Return the service name of the server."
+ (string-append (gethostname) "-" (random-string 4)))
+
+(define %worker-timeout
+ (make-parameter 120))
+
+
+;;;
+;;; Server.
+;;;
+
+(define-record-type* <server>
+ server make-server
+ server?
+ (address server-address)
+ (port server-port)
+ (publish-url server-publish-url))
+
+(define (publish-url address port)
+ "Return the publish url at ADDRESS and PORT."
+ (string-append "http://"; address ":" (number->string port)))
+
+(define (avahi-service->publish-url service)
+ "Return the URL of the publish server corresponding to the service with the
+given NAME."
+ (define (service-txt->publish-port txt)
+ "Parse the service TXT record and return the server publish port."
+ (define (parse-txt)
+ (fold (lambda (param params)
+ (match (string-split param #\=)
+ ((key value)
+ (cons (cons (string->symbol key) value)
+ params))))
+ '()
+ txt))
+
+ (let ((params (parse-txt)))
+ (string->number (assq-ref params 'publish))))
+
+ (let* ((address (avahi-service-address service))
+ (txt (avahi-service-txt service))
+ (publish-port
+ (service-txt->publish-port txt)))
+ (publish-url address publish-port)))
+
+(define (avahi-service->server service)
+ (let ((address (avahi-service-address service))
+ (port (avahi-service-port service))
+ (publish-url (avahi-service->publish-url service)))
+ (server
+ (address address)
+ (port port)
+ (publish-url publish-url))))
+
+
+;;;
+;;; Store publishing.
+;;;
+
+(define* (set-build-options* store url
+ #:key
+ timeout
+ max-silent)
+ "Add URL to the list of STORE substitutes-urls."
+ (set-build-options store
+ #:use-substitutes? #t
+ #:fallback? #f
+ #:keep-going? #t
+ #:print-build-trace #t
+ #:timeout timeout
+ #:max-silent-time max-silent
+ #:build-verbosity 1
+ #:substitute-urls
+ (cons url %default-substitute-urls)))
+
+(define* (publish-server port
+ #:key
+ public-key
+ private-key)
+ "This procedure starts a publishing server listening on PORT in a new
+process and returns the pid of the forked process. Use PUBLIC-KEY and
+PRIVATE-KEY to sign narinfos."
+ (match (primitive-fork)
+ (0
+ (parameterize ((%public-key public-key)
+ (%private-key private-key))
+ (with-store store
+ (let ((log-file (open-file "/tmp/publish.log" "w")))
+ (close-fdes 1)
+ (close-fdes 2)
+ (dup2 (fileno log-file) 1)
+ (dup2 (fileno log-file) 2)
+ (close-port log-file)
+ (let* ((address (make-socket-address AF_INET INADDR_ANY 0))
+ (socket-address
+ (make-socket-address (sockaddr:fam address)
+ (sockaddr:addr address)
+ port))
+ (socket (open-server-socket socket-address)))
+ (run-publish-server socket store
+ #:compressions
+ (list %default-gzip-compression)))))))
+ (pid pid)))
+
+
+;;;
+;;; ZMQ.
+;;;
+
+(define %zmq-context
+ (zmq-create-context))
+
+(define (EINTR-safe proc)
+ "Return a variant of PROC that catches EINTR 'zmq-error' exceptions and
+retries a call to PROC."
+ (define (safe . args)
+ (catch 'zmq-error
+ (lambda ()
+ (apply proc args))
+ (lambda (key errno . rest)
+ (if (= errno EINTR)
+ (apply safe args)
+ (apply throw key errno rest)))))
+
+ safe)
+
+(define zmq-poll*
+ ;; Return a variant of ZMQ-POLL that catches EINTR errors.
+ (EINTR-safe zmq-poll))
+
+(define (zmq-socket-ready? items socket)
+ "Return #t if the given SOCKET is part of ITEMS, a list returned by a
+'zmq-poll' call, return #f otherwise."
+ (find (lambda (item)
+ (eq? (poll-item-socket item) socket))
+ items))
+
+(define (zmq-read-message msg)
+ (call-with-input-string msg read))
+
+(define (zmq-empty-delimiter)
+ "Return an empty ZMQ delimiter used to format message envelopes."
+ (make-bytevector 0))
+
+;; ZMQ Messages.
+(define* (zmq-build-request-message drv
+ #:key
+ priority
+ timeout
+ max-silent
+ timestamp
+ system)
+ "Return a message requesting the build of DRV for SYSTEM."
+ (format #f "~s" `(build (drv ,drv)
+ (priority ,priority)
+ (timeout ,timeout)
+ (max-silent ,max-silent)
+ (timestamp ,timestamp)
+ (system ,system))))
+
+(define (zmq-no-build-message)
+ "Return a message that indicates that no builds are available."
+ (format #f "~s" `(no-build)))
+
+(define (zmq-build-started-message drv worker)
+ "Return a message that indicates that the build of DRV has started."
+ (format #f "~s" `(build-started (drv ,drv) (worker ,worker))))
+
+(define* (zmq-build-failed-message drv url #:optional log)
+ "Return a message that indicates that the build of DRV has failed."
+ (format #f "~s" `(build-failed (drv ,drv) (url ,url) (log ,log))))
+
+(define* (zmq-build-succeeded-message drv url #:optional log)
+ "Return a message that indicates that the build of DRV is done."
+ (format #f "~s" `(build-succeeded (drv ,drv) (url ,url) (log ,log))))
+
+(define (zmq-worker-ping worker)
+ "Return a message that indicates that WORKER is alive."
+ (format #f "~s" `(worker-ping ,worker)))
+
+(define (zmq-worker-ready-message worker)
+ "Return a message that indicates that WORKER is ready."
+ (format #f "~s" `(worker-ready ,worker)))
+
+(define (zmq-worker-request-work-message name)
+ "Return a message that indicates that WORKER is requesting work."
+ (format #f "~s" `(worker-request-work ,name)))
+
+(define remote-server-service-type
+ "_remote-server._tcp")
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 70737fc..4e46434 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -34,6 +34,7 @@
#:use-module ((guix utils) #:select (string-replace-substring))
#:use-module ((cuirass database) #:select (build-status
evaluation-status))
+ #:use-module (cuirass remote)
#:export (html-page
specifications-table
evaluation-info-table
@@ -42,7 +43,8 @@
build-details
evaluation-build-table
running-builds-table
- global-metrics-content))
+ global-metrics-content
+ workers-status))
(define (navigation-items navigation)
(match navigation
@@ -137,6 +139,9 @@ system whose names start with " (code "guile-") ":" (br)
(href "/metrics"))
"Global metrics")
(a (@ (class "dropdown-item")
+ (href "/workers"))
+ "Workers status")
+ (a (@ (class "dropdown-item")
(href "/status"))
"Running builds")))
(li (@ (class "nav-item"))
@@ -1013,3 +1018,38 @@ completed builds divided by the time required to build
them.")
#:title "Pending builds"
#:labels '("Pending builds")
#:colors (list "#3e95cd")))))
+
+(define (workers-status workers builds)
+ (define (build-row build)
+ `(tr
+ (th (@ (scope "row"))
+ (a (@ (href "/build/" ,(assq-ref build #:id) "/details"))
+ ,(assq-ref build #:id)))
+ (td ,(assq-ref build #:job-name))
+ (td ,(time->string
+ (assq-ref build #:starttime)))
+ (td ,(assq-ref build #:system))))
+
+ (define (worker-header worker)
+ `((p ,(integer->char 128994)
+ " "
+ (b ,(worker-name worker))
+ ,(format #f " (~a, ~{~a ~})"
+ (worker-address worker)
+ (worker-systems worker)))))
+
+ (define (worker-table worker builds)
+ `(,@(worker-header worker)
+ (table
+ (@ (class "table table-sm table-hover table-striped"))
+ ,@(if (null? builds)
+ `((th (@ (scope "col")) "Idle"))
+ `((thead (tr (th (@ (scope "col")) "ID")
+ (th (@ (scope "col")) "Job")
+ (th (@ (scope "col")) "Queued at")
+ (th (@ (scope "col")) "System")))
+ (tbody
+ ,(map build-row builds)))))))
+
+ `((p (@ (class "lead")) "Workers status")
+ ,@(map worker-table workers builds)))
diff --git a/src/schema.sql b/src/schema.sql
index 51d0c80..761b48f 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -7,8 +7,9 @@ CREATE TABLE Specifications (
proc_input TEXT NOT NULL, -- name of the input containing the proc that
does the evaluation
proc_file TEXT NOT NULL, -- file containing the procedure that does the
evaluation, relative to proc_input
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
+ proc_args TEXT NOT NULL, -- passed to proc
+ build_outputs TEXT NOT NULL, --specify what build outputs should be made
available for download
+ priority INTEGER NOT NULL DEFAULT 0
);
CREATE TABLE Inputs (
@@ -61,10 +62,13 @@ CREATE TABLE Builds (
evaluation INTEGER NOT NULL,
job_name TEXT NOT NULL,
system TEXT NOT NULL,
- machine TEXT, --optional, machine performing the build.
+ worker TEXT, --optional, worker performing the build.
nix_name TEXT NOT NULL,
log TEXT NOT NULL,
status INTEGER NOT NULL,
+ priority INTEGER NOT NULL DEFAULT 0,
+ max_silent INTEGER NOT NULL DEFAULT 0,
+ timeout INTEGER NOT NULL DEFAULT 0,
timestamp INTEGER NOT NULL,
starttime INTEGER NOT NULL,
stoptime INTEGER NOT NULL,
@@ -96,6 +100,13 @@ CREATE TABLE Events (
event_json TEXT NOT NULL
);
+CREATE TABLE Workers (
+ name TEXT NOT NULL PRIMARY KEY,
+ address TEXT NOT NULL,
+ systems TEXT NOT NULL,
+ last_seen INTEGER NOT NULL
+);
+
-- XXX: All queries targeting Builds and Outputs tables *must* be covered by
-- an index. It is also preferable for the other tables.
CREATE INDEX Builds_status_index ON Builds (status);
@@ -106,6 +117,7 @@ CREATE INDEX Builds_timestamp_stoptime on Builds(timestamp,
stoptime);
CREATE INDEX Builds_stoptime on Builds(stoptime DESC);
CREATE INDEX Builds_stoptime_id on Builds(stoptime DESC, id DESC);
CREATE INDEX Builds_status_ts_id on Builds(status DESC, timestamp DESC, id
ASC);
+CREATE INDEX Builds_priority_timestamp on Builds(priority DESC, timestamp ASC);
CREATE INDEX Evaluations_status_index ON Evaluations (id, status);
CREATE INDEX Evaluations_specification_index ON Evaluations (specification, id
DESC);
diff --git a/src/sql/upgrade-17.sql b/src/sql/upgrade-17.sql
index f74bb92..065ca5f 100644
--- a/src/sql/upgrade-17.sql
+++ b/src/sql/upgrade-17.sql
@@ -1,5 +1,5 @@
BEGIN TRANSACTION;
-ALTER TABLE Builds ADD machine TEXT DEFAULT NULL;
+ALTER TABLE Builds ADD worker TEXT DEFAULT NULL;
COMMIT;
diff --git a/src/sql/upgrade-18.sql b/src/sql/upgrade-18.sql
new file mode 100644
index 0000000..13b9f01
--- /dev/null
+++ b/src/sql/upgrade-18.sql
@@ -0,0 +1,10 @@
+BEGIN TRANSACTION;
+
+CREATE TABLE Workers (
+ name TEXT NOT NULL PRIMARY KEY,
+ address TEXT NOT NULL,
+ systems TEXT NOT NULL,
+ last_seen INTEGER NOT NULL
+);
+
+COMMIT;
diff --git a/src/sql/upgrade-19.sql b/src/sql/upgrade-19.sql
new file mode 100644
index 0000000..4213e11
--- /dev/null
+++ b/src/sql/upgrade-19.sql
@@ -0,0 +1,11 @@
+BEGIN TRANSACTION;
+
+ALTER TABLE Specifications ADD priority INTEGER NOT NULL DEFAULT 0;
+
+ALTER TABLE Builds ADD priority INTEGER NOT NULL DEFAULT 0;
+ALTER TABLE Builds ADD max_silent INTEGER NOT NULL DEFAULT 0;
+ALTER TABLE Builds ADD timeout INTEGER NOT NULL DEFAULT 0;
+
+CREATE INDEX Builds_priority_timestamp on Builds(priority DESC, timestamp ASC);
+
+COMMIT;
diff --git a/tests/database.scm b/tests/database.scm
index 73b347c..d5fa060 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -47,7 +47,8 @@
(#:tag . #f)
(#:commit . #f)
(#:no-compile? . #f))))
- (#:build-outputs . ())))
+ (#:build-outputs . ())
+ (#:priority . 9)))
(define (make-dummy-checkouts fakesha1 fakesha2)
`(((#:commit . ,fakesha1)
diff --git a/tests/http.scm b/tests/http.scm
index 8642425..02f4b08 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -218,12 +218,6 @@
(object->json-string build-query-result)
json->scm)))
- (test-equal "/build/1/log/raw"
- `(302 ,(string->uri-reference "/log/fake-1.0"))
- (let ((response (http-get (test-cuirass-uri "/build/1/log/raw"))))
- (list (response-code response)
- (response-location response))))
-
(test-equal "/build/42"
404
(response-code (http-get (test-cuirass-uri "/build/42"))))