guix
/
guix-cuirass
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git
2
0
Fork 0
Code Issues Releases Wiki Activity

Use a single Cuirass binary.

This commit is contained in:
Mathieu Othacehe 2021-03-22 11:16:47 +01:00
parent cb1b713e0a
commit 43d29317d9
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
12 changed files with 481 additions and 330 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
Makefile.am
View File

@ -23,10 +23,7 @@
# along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
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 \

211
bin/cuirass.in
View File

@ -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 © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.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)))
;; 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)))

29
bin/remote-server.in
View File

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

29
bin/remote-worker.in
View File

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

2
configure.ac
View File

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

14
src/cuirass/base.scm
View File

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

38
bin/evaluate.in → src/cuirass/scripts/evaluate.scm
View File

@ -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/>.
(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."

188
src/cuirass/scripts/register.scm Normal file
View File

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

19
src/cuirass/remote-server.scm → src/cuirass/scripts/remote-server.scm
View File

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

19
src/cuirass/remote-worker.scm → src/cuirass/scripts/remote-worker.scm
View File

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

127
src/cuirass/scripts/web.scm Normal file
View File

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

123
src/cuirass/ui.scm
View File

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