guix-cuirass/bin/cuirass.in

#!/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" "$@"
!#
;;;; 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/>.

(use-modules (cuirass)
             (cuirass ui)
             (cuirass logging)
             (cuirass utils)
             (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.
  -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
      --use-substitutes     Allow usage of pre-built substitutes
      --record-events       Record events for distribution
      --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))
    (database       (single-char #\D) (value #t))
    (port           (single-char #\p) (value #t))
    (listen                           (value #t))
    (interval       (single-char #\I) (value #t))
    (use-substitutes                  (value #f))
    (threads                          (value #t))
    (fallback                         (value #f))
    (record-events                    (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)

  (let ((opts (getopt-long args %options)))
    (parameterize
        ((%program-name     (car args))
         (%package-database (option-ref opts 'database (%package-database)))
         (%package-cachedir
          (option-ref opts 'cache-directory (%package-cachedir)))
         (%use-substitutes? (option-ref opts 'use-substitutes #f))
         (%fallback? (option-ref opts 'fallback #f))
         (%record-events? (option-ref opts 'record-events #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
        (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))

              ;; 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
                      (let ((new-specs (save-module-excursion
                                        (lambda ()
                                          (set-current-module (make-user-module '()))
                                          (primitive-load specfile)))))
                        (for-each db-add-specification new-specs)))
                 (if one-shot?
                     (process-specs (db-get-specifications))
                     (let ((exit-channel (make-channel)))

                       (if (option-ref opts 'web #f)
                           (spawn-fiber
                            (essential-task
                             'web exit-channel
                             (lambda ()
                               (run-cuirass-server #:host host #:port port)))
                            #:parallel? #t)
                           (begin

                             (clear-build-queue)

                             ;; If Cuirass was stopped during an evaluation, consider
                             ;; it done.  Builds that were not registered during this
                             ;; evaluation will be registered during the next
                             ;; evaluation.
                             (db-set-evaluations-done)

                             ;; 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
                               '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)))))))