Use a single Cuirass binary.

Makefile.am

@@ -23,10 +23,7 @@
 # along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 bin_SCRIPTS =                    \
-  bin/cuirass      	  	 \
+  bin/cuirass
-  bin/evaluate      		 \
-  bin/remote-server		 \
-  bin/remote-worker
 
 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		                \

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 <mthl@gnu.org>
+;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
-;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;;
 ;;; 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 <http://www.gnu.org/licenses/>.
 
-(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)))
-
+  (let ((cuirass-main (module-ref (resolve-interface '(cuirass ui))
-  ;; Always have stdout/stderr line-buffered.
+                                  'cuirass-main)))
-  (setvbuf (current-output-port) 'line)
+    (apply cuirass-main args)))
-  (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)))))))

bin/remote-server.in

@@ -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 <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)))

bin/remote-worker.in

@@ -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 <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)))

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])

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
+                         (log-message "Fetching channels for spec '~a'." name)
-                                                   #:authenticate? #f)))
+                         (latest-channel-instances* store channels
+                                                    #:authenticate? #f)))
              (checkouttime (time-second (current-time time-utc)))
              (eval-id (db-add-evaluation name instances
                                          #:timestamp timestamp

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 <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
@@ -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 <http://www.gnu.org/licenses/>.
 
-
+(define-module (cuirass scripts evaluate)
-(use-modules (cuirass database)
+  #:use-module (cuirass database)
-             (cuirass specification)
+  #:use-module (cuirass specification)
-             (guix channels)
+  #:use-module (guix channels)
-             (guix derivations)
+  #:use-module (guix derivations)
-             (guix inferior)
+  #:use-module (guix inferior)
-             (guix licenses)
+  #:use-module (guix licenses)
-             (guix monads)
+  #:use-module (guix monads)
-             (guix store)
+  #:use-module (guix store)
-             (guix ui)
+  #:use-module (guix ui)
-             (guix utils)
+  #:use-module (guix utils)
-             (srfi srfi-1)
+  #:use-module (srfi srfi-1)
-             (ice-9 match)
+  #:use-module (ice-9 match)
-             (ice-9 pretty-print)
+  #:use-module (ice-9 pretty-print)
-             (ice-9 threads))
+  #: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."

src/cuirass/scripts/register.scm

@@ -0,0 +1,188 @@
+;;;; cuirass -- continuous integration tool
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.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/>.
+
+(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)))))))

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 <http://www.gnu.org/licenses/>.
 
-(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 (cuirass-remote-server))
-  #:export (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]...
+  (format #t (G_ "Usage: ~a remote-server [OPTION]...
-Start a remote build server.\n"))
+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)

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 <http://www.gnu.org/licenses/>.
 
-(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 (cuirass-remote-worker))
-  #: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]...
+  (format #t "Usage: ~a remote-worker [OPTION]...
-Start a remote build worker.\n"))
+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)

src/cuirass/scripts/web.scm

@@ -0,0 +1,127 @@
+;;;; cuirass -- continuous integration tool
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.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/>.
+
+(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)))))))

src/cuirass/ui.scm

@@ -1,5 +1,6 @@
 ;;; ui.scm -- user interface facilities for command-line tools
 ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
 ;;;
 ;;; 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 "cuirass"))
-  (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)))))
 
 (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 <http://gnu.org/licenses/gpl.html>
 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))