diff --git a/Makefile.am b/Makefile.am
index 4806036..41ea7fc 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -23,10 +23,7 @@
# along with Cuirass. If not, see .
bin_SCRIPTS = \
- bin/cuirass \
- bin/evaluate \
- bin/remote-server \
- bin/remote-worker
+ bin/cuirass
noinst_SCRIPTS = pre-inst-env
@@ -58,9 +55,12 @@ dist_pkgmodule_DATA = \
src/cuirass/notification.scm \
src/cuirass/parameters.scm \
src/cuirass/remote.scm \
- src/cuirass/remote-server.scm \
- src/cuirass/remote-worker.scm \
src/cuirass/rss.scm \
+ src/cuirass/scripts/evaluate.scm \
+ src/cuirass/scripts/register.scm \
+ src/cuirass/scripts/remote-server.scm \
+ src/cuirass/scripts/remote-worker.scm \
+ src/cuirass/scripts/web.scm \
src/cuirass/specification.scm \
src/cuirass/ui.scm \
src/cuirass/utils.scm \
diff --git a/bin/cuirass.in b/bin/cuirass.in
index 8d911bb..207eecf 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -6,10 +6,7 @@
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
!#
;;;; cuirass -- continuous integration tool
-;;; Copyright © 2016 Mathieu Lirzin
-;;; Copyright © 2017 Mathieu Othacehe
-;;; Copyright © 2018 Ludovic Courtès
-;;; Copyright © 2018 Clément Lassieur
+;;; Copyright © 2021 Mathieu Othacehe
;;;
;;; This file is part of Cuirass.
;;;
@@ -26,207 +23,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
;;; You should have received a copy of the GNU General Public License
;;; along with Cuirass. If not, see .
-(use-modules (cuirass)
- (cuirass base)
- (cuirass database)
- (cuirass ui)
- (cuirass logging)
- (cuirass metrics)
- (cuirass notification)
- (cuirass specification)
- (cuirass utils)
- (cuirass watchdog)
- (cuirass zabbix)
- (guix ui)
- ((guix build utils) #:select (mkdir-p))
- (fibers)
- (fibers channels)
- (srfi srfi-19)
- (ice-9 threads) ;for 'current-processor-count'
- (ice-9 getopt-long))
-
-(define (show-help)
- (format #t "Usage: ~a [OPTIONS]~%" (%program-name))
- (display "Run build jobs from internal database.
-
- --one-shot Evaluate and build jobs only once
- --cache-directory=DIR Use DIR for storing repository data
- --fallback Fall back to building when the substituter fails.
- -S --specifications=SPECFILE
- Add specifications from SPECFILE to database.
- -P --parameters=PARAMFILE
- Read parameters for PARAMFILE.
- -D --database=DB Use DB to store build results.
- --ttl=DURATION Keep build results live for at least DURATION.
- --web Start the web interface
- -p --port=NUM Port of the HTTP server.
- --listen=HOST Listen on the network interface for HOST
- -I, --interval=N Wait N seconds between each poll
- --build-remote Use the remote build mechanism
- --use-substitutes Allow usage of pre-built substitutes
- --threads=N Use up to N kernel threads
- -V, --version Display version
- -h, --help Display this help message")
- (newline)
- (show-package-information))
-
-(define %options
- '((one-shot (value #f))
- (web (value #f))
- (cache-directory (value #t))
- (specifications (single-char #\S) (value #t))
- (parameters (single-char #\P) (value #t))
- (database (single-char #\D) (value #t))
- (port (single-char #\p) (value #t))
- (listen (value #t))
- (interval (single-char #\I) (value #t))
- (build-remote (value #f))
- (use-substitutes (value #f))
- (threads (value #t))
- (fallback (value #f))
- (ttl (value #t))
- (version (single-char #\V) (value #f))
- (help (single-char #\h) (value #f))))
-
-
-;;;
-;;; Entry point.
-;;;
-
(define* (main #:optional (args (command-line)))
-
- ;; Always have stdout/stderr line-buffered.
- (setvbuf (current-output-port) 'line)
- (setvbuf (current-error-port) 'line)
-
- ;; Use a default locale.
- (setlocale LC_ALL "en_US.UTF-8")
-
- (let ((opts (getopt-long args %options)))
- (parameterize
- ((%program-name (car args))
- (%create-database? (not (option-ref opts 'web #f)))
- (%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))
- (%gc-root-ttl
- (time-second (string->duration (option-ref opts 'ttl "30d")))))
- (cond
- ((option-ref opts 'help #f)
- (show-help)
- (exit 0))
- ((option-ref opts 'version #f)
- (show-version)
- (exit 0))
- (else
- ;; If we cannot create the gcroot directory, it should be done later
- ;; on by guix-daemon itself.
- (false-if-exception (mkdir-p (%gc-root-directory)))
- (let ((one-shot? (option-ref opts 'one-shot #f))
- (port (string->number (option-ref opts 'port "8080")))
- (host (option-ref opts 'listen "localhost"))
- (interval (string->number (option-ref opts 'interval "300")))
- (specfile (option-ref opts 'specifications #f))
- (paramfile (option-ref opts 'parameters #f))
-
- ;; Since our work is mostly I/O-bound, default to a maximum of 4
- ;; kernel threads. Going beyond that can increase overhead (GC
- ;; may not scale well, work-stealing may become detrimental,
- ;; etc.) for little in return.
- (threads (or (and=> (option-ref opts 'threads #f)
- string->number)
- (min (current-processor-count) 4))))
- (prepare-git)
-
- (log-message "running Fibers on ~a kernel threads" threads)
- (run-fibers
- (lambda ()
- (with-database
- (and specfile
- (for-each db-add-or-update-specification
- (read-specifications specfile)))
- (and paramfile (read-parameters paramfile))
-
- (if one-shot?
- (process-specs (db-get-specifications))
- (let ((exit-channel (make-channel)))
- (start-watchdog)
- (if (option-ref opts 'web #f)
- (begin
- (spawn-fiber
- (essential-task
- 'web exit-channel
- (lambda ()
- (run-cuirass-server #:host host
- #:port port)))
- #:parallel? #t)
-
- (spawn-fiber
- (essential-task
- 'monitor exit-channel
- (lambda ()
- (while #t
- (log-monitoring-stats)
- (sleep 600))))))
-
- (begin
- (parameterize (((@@ (fibers internal)
- current-fiber) #f))
- (start-notification-thread))
- (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
- ;; doesn't actually help since these are non-resumable
- ;; continuations.) Thus, reduce the tick rate.
- #:hz 10
-
- #:parallelism threads
- #:drain? #t)))))))
+ (let ((cuirass-main (module-ref (resolve-interface '(cuirass ui))
+ 'cuirass-main)))
+ (apply cuirass-main args)))
diff --git a/bin/remote-server.in b/bin/remote-server.in
deleted file mode 100644
index 6425d51..0000000
--- a/bin/remote-server.in
+++ /dev/null
@@ -1,29 +0,0 @@
-#!/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
-;;;
-;;; 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 .
-
-(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
deleted file mode 100644
index 8a3830c..0000000
--- a/bin/remote-worker.in
+++ /dev/null
@@ -1,29 +0,0 @@
-#!/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
-;;;
-;;; 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 .
-
-(use-modules (cuirass remote-worker))
-
-(define* (main #:optional (args (command-line)))
- (remote-worker (cdr args)))
diff --git a/configure.ac b/configure.ac
index a40628e..960ce4e 100644
--- a/configure.ac
+++ b/configure.ac
@@ -23,7 +23,7 @@ AC_PREREQ([2.61])
AC_INIT([Cuirass],
m4_esyscmd([build-aux/git-version-gen .tarball-version]),
[bug-guix@gnu.org], [cuirass],
- [https://www.gnu.org/software/guix/])
+ [https://guix.gnu.org/en/cuirass/])
AC_CONFIG_SRCDIR([bin/cuirass.in])
AC_CONFIG_AUX_DIR([build-aux])
AC_REQUIRE_AUX_FILE([git-version-gen])
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 377b9ca..806cbed 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -273,7 +273,8 @@ Return a list of jobs that are associated to EVAL-ID."
(let* ((port (non-blocking-port
(with-error-to-port (cdr log-pipe)
(lambda ()
- (open-pipe* OPEN_READ "evaluate"
+ (open-pipe* OPEN_READ "cuirass"
+ "evaluate"
(%package-database)
(object->string eval-id))))))
(result (match (read/non-blocking port)
@@ -665,6 +666,12 @@ by BUILD-OUTPUTS."
(when (or directory file)
(set-tls-certificate-locations! directory file)))))
+(define (latest-channel-instances* . args)
+ (parameterize ((current-output-port (%make-void-port "w"))
+ (current-error-port (%make-void-port "w"))
+ (guix-warning-port (%make-void-port "w")))
+ (apply latest-channel-instances args)))
+
(define (process-specs jobspecs)
"Evaluate and build JOBSPECS and store results in the database."
(define (process spec)
@@ -673,8 +680,9 @@ by BUILD-OUTPUTS."
(timestamp (time-second (current-time time-utc)))
(channels (specification-channels spec))
(instances (non-blocking
- (latest-channel-instances store channels
- #:authenticate? #f)))
+ (log-message "Fetching channels for spec '~a'." name)
+ (latest-channel-instances* store channels
+ #:authenticate? #f)))
(checkouttime (time-second (current-time time-utc)))
(eval-id (db-add-evaluation name instances
#:timestamp timestamp
diff --git a/bin/evaluate.in b/src/cuirass/scripts/evaluate.scm
similarity index 89%
rename from bin/evaluate.in
rename to src/cuirass/scripts/evaluate.scm
index b955dfc..6183162 100644
--- a/bin/evaluate.in
+++ b/src/cuirass/scripts/evaluate.scm
@@ -1,8 +1,3 @@
-#!/bin/sh
-# -*- scheme -*-
-# @configure_input@
-exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
-!#
;;;; evaluate -- convert a specification to a job list
;;; Copyright © 2016, 2018 Ludovic Courtès
;;; Copyright © 2016, 2017 Mathieu Lirzin
@@ -24,21 +19,22 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
;;; You should have received a copy of the GNU General Public License
;;; along with Cuirass. If not, see .
-
-(use-modules (cuirass database)
- (cuirass specification)
- (guix channels)
- (guix derivations)
- (guix inferior)
- (guix licenses)
- (guix monads)
- (guix store)
- (guix ui)
- (guix utils)
- (srfi srfi-1)
- (ice-9 match)
- (ice-9 pretty-print)
- (ice-9 threads))
+(define-module (cuirass scripts evaluate)
+ #:use-module (cuirass database)
+ #:use-module (cuirass specification)
+ #:use-module (guix channels)
+ #:use-module (guix derivations)
+ #:use-module (guix inferior)
+ #:use-module (guix licenses)
+ #:use-module (guix monads)
+ #:use-module (guix store)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 threads)
+ #:export (cuirass-evaluate))
(define (checkouts->channel-instances checkouts)
"Return the list of CHANNEL-INSTANCE records describing the given
@@ -94,7 +90,7 @@ of channel instances."
(built-derivations (list profile))
(return (derivation->output-path profile)))))))
-(define* (main #:optional (args (command-line)))
+(define (cuirass-evaluate args)
"This procedure spawns an inferior on the given channels. An evaluation
procedure is called within that inferior, it returns a list of jobs that are
registered in database."
diff --git a/src/cuirass/scripts/register.scm b/src/cuirass/scripts/register.scm
new file mode 100644
index 0000000..ff7d0e2
--- /dev/null
+++ b/src/cuirass/scripts/register.scm
@@ -0,0 +1,188 @@
+;;;; cuirass -- continuous integration tool
+;;; Copyright © 2016 Mathieu Lirzin
+;;; Copyright © 2017 Mathieu Othacehe
+;;; Copyright © 2018 Ludovic Courtès
+;;; Copyright © 2018 Clément Lassieur
+;;;
+;;; 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 .
+
+(define-module (cuirass scripts register)
+ #:use-module (cuirass)
+ #:use-module (cuirass base)
+ #:use-module (cuirass database)
+ #:use-module (cuirass ui)
+ #:use-module (cuirass logging)
+ #:use-module (cuirass metrics)
+ #:use-module (cuirass notification)
+ #:use-module (cuirass specification)
+ #:use-module (cuirass utils)
+ #:use-module (cuirass watchdog)
+ #:use-module (cuirass zabbix)
+ #:use-module (guix ui)
+ #:use-module ((guix build utils) #:select (mkdir-p))
+ #:use-module (fibers)
+ #:use-module (fibers channels)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 threads)
+ #:use-module (ice-9 getopt-long)
+ #:export (cuirass-register))
+
+(define (show-help)
+ (format #t "Usage: ~a register [OPTIONS]~%" (%program-name))
+ (display "Register build jobs in database.
+
+ --one-shot Evaluate and build jobs only once
+ --cache-directory=DIR Use DIR for storing repository data
+ --fallback Fall back to building when the substituter fails.
+ -S --specifications=SPECFILE
+ Add specifications from SPECFILE to database.
+ -P --parameters=PARAMFILE
+ Read parameters for PARAMFILE.
+ -D --database=DB Use DB to store build results.
+ --ttl=DURATION Keep build results live for at least DURATION.
+ -I, --interval=N Wait N seconds between each poll
+ --build-remote Use the remote build mechanism
+ --use-substitutes Allow usage of pre-built substitutes
+ --threads=N Use up to N kernel threads
+ -V, --version Display version
+ -h, --help Display this help message")
+ (newline)
+ (show-package-information))
+
+(define %options
+ '((one-shot (value #f))
+ (cache-directory (value #t))
+ (specifications (single-char #\S) (value #t))
+ (parameters (single-char #\P) (value #t))
+ (database (single-char #\D) (value #t))
+ (interval (single-char #\I) (value #t))
+ (build-remote (value #f))
+ (use-substitutes (value #f))
+ (threads (value #t))
+ (fallback (value #f))
+ (ttl (value #t))
+ (version (single-char #\V) (value #f))
+ (help (single-char #\h) (value #f))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (cuirass-register args)
+ (let ((opts (getopt-long args %options)))
+ (parameterize
+ ((%create-database? #t)
+ (%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))
+ (%gc-root-ttl
+ (time-second (string->duration (option-ref opts 'ttl "30d")))))
+ (cond
+ ((option-ref opts 'help #f)
+ (show-help)
+ (exit 0))
+ ((option-ref opts 'version #f)
+ (show-version)
+ (exit 0))
+ (else
+ ;; If we cannot create the gcroot directory, it should be done later
+ ;; on by guix-daemon itself.
+ (false-if-exception (mkdir-p (%gc-root-directory)))
+ (let ((one-shot? (option-ref opts 'one-shot #f))
+ (interval (string->number (option-ref opts 'interval "300")))
+ (specfile (option-ref opts 'specifications #f))
+ (paramfile (option-ref opts 'parameters #f))
+
+ ;; Since our work is mostly I/O-bound, default to a maximum of 4
+ ;; kernel threads. Going beyond that can increase overhead (GC
+ ;; may not scale well, work-stealing may become detrimental,
+ ;; etc.) for little in return.
+ (threads (or (and=> (option-ref opts 'threads #f)
+ string->number)
+ (min (current-processor-count) 4))))
+ (prepare-git)
+
+ (log-message "running Fibers on ~a kernel threads" threads)
+ (run-fibers
+ (lambda ()
+ (with-database
+ (and specfile
+ (for-each db-add-or-update-specification
+ (read-specifications specfile)))
+ (and paramfile (read-parameters paramfile))
+
+ (if one-shot?
+ (process-specs (db-get-specifications))
+ (let ((exit-channel (make-channel)))
+ (start-watchdog)
+ (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
+ ;; doesn't actually help since these are non-resumable
+ ;; continuations.) Thus, reduce the tick rate.
+ #:hz 10
+
+ #:parallelism threads
+ #:drain? #t)))))))
diff --git a/src/cuirass/remote-server.scm b/src/cuirass/scripts/remote-server.scm
similarity index 98%
rename from src/cuirass/remote-server.scm
rename to src/cuirass/scripts/remote-server.scm
index 16a7e6c..43547f4 100644
--- a/src/cuirass/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -16,11 +16,12 @@
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see .
-(define-module (cuirass remote-server)
+(define-module (cuirass scripts remote-server)
#:use-module (cuirass base)
#:use-module (cuirass config)
#:use-module (cuirass database)
#:use-module (cuirass logging)
+ #:use-module (cuirass ui)
#:use-module (cuirass notification)
#:use-module (cuirass remote)
#:use-module (cuirass utils)
@@ -59,8 +60,7 @@
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 threads)
-
- #:export (remote-server))
+ #:export (cuirass-remote-server))
;; Indicate if the process has to be stopped.
(define %stop-process?
@@ -88,8 +88,8 @@
"Cuirass remote server")
(define (show-help)
- (format #t (G_ "Usage: remote-server [OPTION]...
-Start a remote build server.\n"))
+ (format #t (G_ "Usage: ~a remote-server [OPTION]...
+Start a remote build server.\n") (%program-name))
(display (G_ "
-b, --backend-port=PORT listen worker connections on PORT"))
(display (G_ "
@@ -440,15 +440,10 @@ exiting."
(leave (G_ "user '~a' not found: ~a~%")
user (apply format #f message args)))))
-(define (remote-server args)
+(define (cuirass-remote-server args)
(signal-handler)
-
- ;; Always have stdout/stderr line-buffered.
- (setvbuf (current-output-port) 'line)
- (setvbuf (current-error-port) 'line)
-
(with-error-handling
- (let* ((opts (args-fold* args %options
+ (let* ((opts (args-fold* (cdr args) %options
(lambda (opt name arg result)
(leave (G_ "~A: unrecognized option~%") name))
(lambda (arg result)
diff --git a/src/cuirass/remote-worker.scm b/src/cuirass/scripts/remote-worker.scm
similarity index 97%
rename from src/cuirass/remote-worker.scm
rename to src/cuirass/scripts/remote-worker.scm
index 69ccf02..93300ab 100644
--- a/src/cuirass/remote-worker.scm
+++ b/src/cuirass/scripts/remote-worker.scm
@@ -16,9 +16,10 @@
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see .
-(define-module (cuirass remote-worker)
+(define-module (cuirass scripts remote-worker)
#:use-module (cuirass base)
#:use-module (cuirass remote)
+ #:use-module (cuirass ui)
#:use-module (gcrypt pk-crypto)
#:use-module (guix avahi)
#:use-module (guix config)
@@ -49,16 +50,15 @@
#:use-module (ice-9 atomic)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
-
- #:export (remote-worker))
+ #:export (cuirass-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"))
+ (format #t "Usage: ~a remote-worker [OPTION]...
+Start a remote build worker.\n" (%program-name))
(display (G_ "
-w, --workers=COUNT start COUNT parallel workers"))
(display (G_ "
@@ -343,15 +343,10 @@ exiting."
(exit 1)))))
-(define (remote-worker args)
+(define (cuirass-remote-worker args)
(signal-handler)
-
- ;; Always have stdout/stderr line-buffered.
- (setvbuf (current-output-port) 'line)
- (setvbuf (current-error-port) 'line)
-
(with-error-handling
- (let* ((opts (args-fold* args %options
+ (let* ((opts (args-fold* (cdr args) %options
(lambda (opt name arg result)
(leave (G_ "~A: unrecognized option~%") name))
(lambda (arg result)
diff --git a/src/cuirass/scripts/web.scm b/src/cuirass/scripts/web.scm
new file mode 100644
index 0000000..fe343c6
--- /dev/null
+++ b/src/cuirass/scripts/web.scm
@@ -0,0 +1,127 @@
+;;;; cuirass -- continuous integration tool
+;;; Copyright © 2016 Mathieu Lirzin
+;;; Copyright © 2017 Mathieu Othacehe
+;;; Copyright © 2018 Ludovic Courtès
+;;; Copyright © 2018 Clément Lassieur
+;;;
+;;; 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 .
+
+(define-module (cuirass scripts web)
+ #:use-module (cuirass)
+ #:use-module (cuirass base)
+ #:use-module (cuirass database)
+ #:use-module (cuirass ui)
+ #:use-module (cuirass logging)
+ #:use-module (cuirass metrics)
+ #:use-module (cuirass notification)
+ #:use-module (cuirass specification)
+ #:use-module (cuirass utils)
+ #:use-module (cuirass watchdog)
+ #:use-module (cuirass zabbix)
+ #:use-module (guix ui)
+ #:use-module ((guix build utils) #:select (mkdir-p))
+ #:use-module (fibers)
+ #:use-module (fibers channels)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 threads)
+ #:use-module (ice-9 getopt-long)
+ #:export (cuirass-web))
+
+(define (show-help)
+ (format #t "Usage: ~a web [OPTIONS]~%" (%program-name))
+ (display "Run the Cuirass web server.
+ -P --parameters=PARAMFILE
+ Read parameters for PARAMFILE.
+ -D --database=DB Use DB to store build results.
+ -p --port=NUM Port of the HTTP server.
+ --listen=HOST Listen on the network interface for HOST
+ -V, --version Display version
+ -h, --help Display this help message")
+ (newline)
+ (show-package-information))
+
+(define %options
+ '((parameters (single-char #\P) (value #t))
+ (database (single-char #\D) (value #t))
+ (port (single-char #\p) (value #t))
+ (listen (value #t))
+ (version (single-char #\V) (value #f))
+ (help (single-char #\h) (value #f))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (cuirass-web args)
+ (let ((opts (getopt-long args %options)))
+ (parameterize
+ ((%create-database? #f)
+ (%package-database (option-ref opts 'database (%package-database))))
+ (cond
+ ((option-ref opts 'help #f)
+ (show-help)
+ (exit 0))
+ ((option-ref opts 'version #f)
+ (show-version)
+ (exit 0))
+ (else
+ (let ((port (string->number (option-ref opts 'port "8080")))
+ (host (option-ref opts 'listen "localhost"))
+ (paramfile (option-ref opts 'parameters #f))
+
+ ;; Since our work is mostly I/O-bound, default to a maximum of 4
+ ;; kernel threads. Going beyond that can increase overhead (GC
+ ;; may not scale well, work-stealing may become detrimental,
+ ;; etc.) for little in return.
+ (threads (or (and=> (option-ref opts 'threads #f)
+ string->number)
+ (min (current-processor-count) 4))))
+ (prepare-git)
+
+ (log-message "running Fibers on ~a kernel threads" threads)
+ (run-fibers
+ (lambda ()
+ (with-database
+ (and paramfile (read-parameters paramfile))
+
+ (let ((exit-channel (make-channel)))
+ (start-watchdog)
+ (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)))))
+ (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
+ ;; doesn't actually help since these are non-resumable
+ ;; continuations.) Thus, reduce the tick rate.
+ #:hz 10
+
+ #:parallelism threads
+ #:drain? #t)))))))
diff --git a/src/cuirass/ui.scm b/src/cuirass/ui.scm
index ae875c6..cdf4d08 100644
--- a/src/cuirass/ui.scm
+++ b/src/cuirass/ui.scm
@@ -1,5 +1,6 @@
;;; ui.scm -- user interface facilities for command-line tools
;;; Copyright © 2016, 2017 Mathieu Lirzin
+;;; Copyright © 2021 Mathieu Othacehe
;;;
;;; This file is part of Cuirass.
;;;
@@ -18,31 +19,28 @@
(define-module (cuirass ui)
#:use-module (cuirass config)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
#:export (;; Procedures.
show-version
show-package-information
+ cuirass-main
;; Parameters.
%program-name))
(define %program-name
- ;; Similar in spirit to Gnulib 'progname' module.
- (make-parameter ""
- (lambda (val)
- (cond ((not (string? val))
- (scm-error 'wrong-type-arg
- "%program-name" "Not a string: ~S" (list #f) #f))
- ((string-rindex val #\/) => (lambda (idx) (substring val (1+ idx))))
- (else val)))))
+ (make-parameter "cuirass"))
(define (show-version)
"Display version information for COMMAND."
(simple-format #t "~a (~a) ~a~%"
(%program-name) %package-name %package-version)
- (display "Copyright (C) 2018 the Cuirass authors
+ (display "Copyright (C) 2021 the Cuirass authors
License GPLv3+: GNU GPL version 3 or later
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.")
- (newline))
+ (newline)
+ (exit 0))
(define (show-package-information)
(newline)
@@ -50,3 +48,108 @@ There is NO WARRANTY, to the extent permitted by law.")
(newline)
(format #t "~A home page: <~A>" %package-name %package-url)
(newline))
+
+(define (install-locale)
+ "Install the current locale settings."
+ (catch 'system-error
+ (lambda _
+ (setlocale LC_ALL ""))
+ (lambda args
+ ;; We're now running in the "C" locale. Try to install a UTF-8 locale
+ ;; instead.
+ (false-if-exception (setlocale LC_ALL "en_US.utf8")))))
+
+(define (initialize-cuirass)
+ "Perform the usual initialization for stand-alone Cuirass commands."
+ (install-locale)
+
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line))
+
+(define (show-cuirass-usage)
+ (format (current-error-port)
+ "Try `cuirass --help' for more information.~%")
+ (exit 1))
+
+(define (show-cuirass-help)
+ (format #t "Usage: cuirass COMMAND ARGS...
+Run COMMAND with ARGS.\n")
+ (newline)
+ (format #t "COMMAND must be one of the sub-commands listed below:
+- register
+- remote-server
+- remote-worker
+- web~%"))
+
+(define (run-cuirass-command command . args)
+ "Run COMMAND with the given ARGS. Report an error when COMMAND is not
+found."
+ (define module
+ ;; Check if there is a matching extension.
+ (catch 'misc-error
+ (lambda ()
+ (resolve-interface `(cuirass scripts ,command)))
+ (lambda _
+ (format (current-error-port)
+ "cuirass: ~a: command not found~%" command)
+ (show-cuirass-usage))))
+
+ (let ((command-main (module-ref module
+ (symbol-append 'cuirass- command))))
+ ;; Disable canonicalization so we don't don't stat unreasonably.
+ (with-fluids ((%file-port-name-canonicalization #f))
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (command-main (cons command args)))
+ (lambda ()
+ #t)))))
+
+(define-syntax-rule (leave-on-EPIPE exp ...)
+ "Run EXP... in a context where EPIPE errors are caught and lead to 'exit'
+with successful exit code. This is useful when writing to the standard output
+may lead to EPIPE, because the standard output is piped through 'head' or
+similar."
+ (catch 'system-error
+ (lambda ()
+ exp ...)
+ (lambda args
+ ;; We really have to exit this brutally, otherwise Guile eventually
+ ;; attempts to flush all the ports, leading to an uncaught EPIPE down
+ ;; the path.
+ (if (= EPIPE (system-error-errno args))
+ (primitive-_exit 0)
+ (apply throw args)))))
+
+(define (run-cuirass args)
+ "Run the 'cuirass' command defined by command line ARGS."
+ (define option? (cut string-prefix? "-" <>))
+
+ ;; The default %LOAD-EXTENSIONS includes the empty string, which doubles the
+ ;; number of 'stat' calls per entry in %LOAD-PATH. Shamelessly remove it.
+ (set! %load-extensions '(".scm"))
+
+ (match args
+ (()
+ (format (current-error-port)
+ "cuirass: missing command name~%")
+ (show-cuirass-usage))
+ ((or ("-h") ("--help"))
+ (leave-on-EPIPE (show-cuirass-help)))
+ ((or ("-V") ("--version"))
+ (show-version))
+ (((? option? o) args ...)
+ (format (current-error-port)
+ "cuirass: unrecognized option '~a'~%" o)
+ (show-cuirass-usage))
+ (("help" command)
+ (apply run-cuirass-command (string->symbol command)
+ '("--help")))
+ (("help" args ...)
+ (leave-on-EPIPE (show-cuirass-help)))
+ ((command args ...)
+ (apply run-cuirass-command (string->symbol command) args))))
+
+(define (cuirass-main arg0 . args)
+ (initialize-cuirass)
+ (run-cuirass args))