2016-05-11 19:59:47 +02:00
|
|
|
|
#!/bin/sh
|
|
|
|
|
# -*- scheme -*-
|
2016-11-12 17:36:18 +01:00
|
|
|
|
# @configure_input@
|
2016-12-24 01:08:04 +01:00
|
|
|
|
#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"
|
2016-05-11 19:59:47 +02:00
|
|
|
|
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|
|
|
|
!#
|
2016-11-12 17:36:18 +01:00
|
|
|
|
;;;; cuirass -- continuous integration tool
|
2016-05-11 19:59:47 +02:00
|
|
|
|
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
|
2017-01-25 09:54:54 +01:00
|
|
|
|
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
2016-05-11 19:59:47 +02:00
|
|
|
|
;;;
|
|
|
|
|
;;; This file is part of Cuirass.
|
|
|
|
|
;;;
|
2016-07-23 12:10:04 +02:00
|
|
|
|
;;; 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.
|
2016-05-11 19:59:47 +02:00
|
|
|
|
;;;
|
2016-07-23 12:10:04 +02:00
|
|
|
|
;;; Cuirass is distributed in the hope that it will be useful,
|
|
|
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
2016-05-11 19:59:47 +02:00
|
|
|
|
;;; 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/>.
|
|
|
|
|
|
2016-08-02 17:04:00 +02:00
|
|
|
|
(use-modules (cuirass)
|
2016-06-10 22:27:41 +02:00
|
|
|
|
(cuirass ui)
|
2018-01-22 23:07:10 +01:00
|
|
|
|
(cuirass logging)
|
2017-07-01 12:23:23 +02:00
|
|
|
|
(guix ui)
|
2018-01-22 23:07:10 +01:00
|
|
|
|
(fibers)
|
2016-07-26 17:16:44 +02:00
|
|
|
|
(ice-9 getopt-long))
|
2016-05-11 19:59:47 +02:00
|
|
|
|
|
2016-07-13 18:34:08 +02:00
|
|
|
|
(define (show-help)
|
2016-07-26 11:58:28 +02:00
|
|
|
|
(format #t "Usage: ~a [OPTIONS]~%" (%program-name))
|
|
|
|
|
(display "Run build jobs from internal database.
|
2016-06-10 22:27:41 +02:00
|
|
|
|
|
2016-07-02 23:08:52 +02:00
|
|
|
|
--one-shot Evaluate and build jobs only once
|
2016-07-02 15:34:40 +02:00
|
|
|
|
--cache-directory=DIR Use DIR for storing repository data
|
2017-07-11 11:38:18 +02:00
|
|
|
|
--fallback Fall back to building when the substituter fails.
|
2017-01-25 09:54:54 +01:00
|
|
|
|
-L --load-path=DIR Prepend DIR to Guix package module search path.
|
2016-07-26 11:58:28 +02:00
|
|
|
|
-S --specifications=SPECFILE
|
|
|
|
|
Add specifications from SPECFILE to database.
|
2016-06-26 17:02:23 +02:00
|
|
|
|
-D --database=DB Use DB to store build results.
|
2016-12-24 02:15:17 +01:00
|
|
|
|
-p --port=NUM Port of the HTTP server.
|
2017-09-18 21:57:05 +02:00
|
|
|
|
--listen=HOST Listen on the network interface for HOST
|
2016-07-26 16:17:54 +02:00
|
|
|
|
-I, --interval=N Wait N seconds between each poll
|
2016-09-15 22:50:42 +02:00
|
|
|
|
--use-substitutes Allow usage of pre-built substitutes
|
2016-06-10 22:27:41 +02:00
|
|
|
|
-V, --version Display version
|
|
|
|
|
-h, --help Display this help message")
|
|
|
|
|
(newline)
|
|
|
|
|
(show-package-information))
|
|
|
|
|
|
|
|
|
|
(define %options
|
2016-07-26 11:58:28 +02:00
|
|
|
|
'((one-shot (value #f))
|
|
|
|
|
(cache-directory (value #t))
|
2017-01-25 09:54:54 +01:00
|
|
|
|
(load-path (single-char #\L) (value #t))
|
2016-07-26 11:58:28 +02:00
|
|
|
|
(specifications (single-char #\S) (value #t))
|
|
|
|
|
(database (single-char #\D) (value #t))
|
2016-12-24 02:15:17 +01:00
|
|
|
|
(port (single-char #\p) (value #t))
|
2017-09-18 21:57:05 +02:00
|
|
|
|
(listen (value #t))
|
2016-07-26 11:58:28 +02:00
|
|
|
|
(interval (single-char #\I) (value #t))
|
2016-09-15 22:50:42 +02:00
|
|
|
|
(use-substitutes (value #f))
|
2017-07-11 11:38:18 +02:00
|
|
|
|
(fallback (value #f))
|
2016-07-26 11:58:28 +02:00
|
|
|
|
(version (single-char #\V) (value #f))
|
|
|
|
|
(help (single-char #\h) (value #f))))
|
2016-06-10 22:27:41 +02:00
|
|
|
|
|
2016-05-11 19:59:47 +02:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Entry point.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define* (main #:optional (args (command-line)))
|
2016-08-02 18:13:48 +02:00
|
|
|
|
(let ((opts (getopt-long args %options)))
|
2016-07-01 14:39:21 +02:00
|
|
|
|
(parameterize
|
|
|
|
|
((%program-name (car args))
|
2016-07-02 15:34:40 +02:00
|
|
|
|
(%package-database (option-ref opts 'database (%package-database)))
|
|
|
|
|
(%package-cachedir
|
2016-09-15 22:50:42 +02:00
|
|
|
|
(option-ref opts 'cache-directory (%package-cachedir)))
|
2017-01-25 09:54:54 +01:00
|
|
|
|
(%guix-package-path
|
|
|
|
|
(option-ref opts 'load-path (%guix-package-path)))
|
2017-07-11 11:38:18 +02:00
|
|
|
|
(%use-substitutes? (option-ref opts 'use-substitutes #f))
|
|
|
|
|
(%fallback? (option-ref opts 'fallback #f)))
|
2016-07-01 14:39:21 +02:00
|
|
|
|
(cond
|
|
|
|
|
((option-ref opts 'help #f)
|
|
|
|
|
(show-help)
|
|
|
|
|
(exit 0))
|
|
|
|
|
((option-ref opts 'version #f)
|
|
|
|
|
(show-version)
|
|
|
|
|
(exit 0))
|
|
|
|
|
(else
|
2016-07-02 23:08:52 +02:00
|
|
|
|
(let ((one-shot? (option-ref opts 'one-shot #f))
|
2016-12-24 02:15:17 +01:00
|
|
|
|
(port (string->number (option-ref opts 'port "8080")))
|
2017-09-18 21:57:05 +02:00
|
|
|
|
(host (option-ref opts 'listen "localhost"))
|
2018-01-22 23:07:10 +01:00
|
|
|
|
(interval (string->number (option-ref opts 'interval "300")))
|
2016-07-26 11:58:28 +02:00
|
|
|
|
(specfile (option-ref opts 'specifications #f)))
|
2018-01-22 13:04:20 +01:00
|
|
|
|
(prepare-git)
|
2018-01-22 23:07:10 +01:00
|
|
|
|
(run-fibers
|
|
|
|
|
(lambda ()
|
|
|
|
|
(with-database db
|
|
|
|
|
(and specfile
|
|
|
|
|
(let ((new-specs (save-module-excursion
|
|
|
|
|
(lambda ()
|
|
|
|
|
(set-current-module (make-user-module '()))
|
|
|
|
|
(primitive-load specfile)))))
|
|
|
|
|
(for-each (lambda (spec) (db-add-specification db spec))
|
|
|
|
|
new-specs)))
|
|
|
|
|
(if one-shot?
|
|
|
|
|
(process-specs db (db-get-specifications db))
|
2018-01-26 14:09:47 +01:00
|
|
|
|
(let ((pending
|
|
|
|
|
(begin
|
|
|
|
|
(log-message "retrieving list of pending builds...")
|
|
|
|
|
(db-get-builds db '((status pending))))))
|
|
|
|
|
|
2018-01-23 23:15:10 +01:00
|
|
|
|
;; First off, restart builds that had not completed or
|
|
|
|
|
;; were not even started on a previous run.
|
|
|
|
|
(spawn-fiber
|
|
|
|
|
(lambda ()
|
2018-01-23 23:45:24 +01:00
|
|
|
|
(with-database db
|
|
|
|
|
(restart-builds db pending))))
|
2018-01-23 23:15:10 +01:00
|
|
|
|
|
2018-01-22 23:07:10 +01:00
|
|
|
|
(spawn-fiber
|
|
|
|
|
(lambda ()
|
|
|
|
|
(with-database db
|
|
|
|
|
(while #t
|
|
|
|
|
(process-specs db (db-get-specifications db))
|
|
|
|
|
(log-message "sleeping for ~a seconds" interval)
|
|
|
|
|
(sleep interval)))))
|
2018-01-23 23:15:10 +01:00
|
|
|
|
|
2018-01-23 17:23:07 +01:00
|
|
|
|
(with-database db
|
|
|
|
|
(run-cuirass-server db
|
|
|
|
|
#:host host
|
|
|
|
|
#:port port))
|
2018-01-22 23:07:10 +01:00
|
|
|
|
*unspecified*))))
|
|
|
|
|
|
|
|
|
|
#:drain? #t)))))))
|