guix-cuirass/bin/cuirass.in

#!/bin/sh
# -*- scheme -*-
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
!#
;;;; cuirass - continuous integration system
;;;
;;; Copyright © 2016 Mathieu Lirzin <mthl@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 base)
             (cuirass job)
             (cuirass ui)
             (ice-9 getopt-long)
             (ice-9 match))

(define* (show-help prog)
  (simple-format #t "Usage: ~a [OPTIONS] [CACHEDIR]" prog)
  (display "
Run Guix job from a git repository cloned in CACHEDIR.

  -f  --use-file=FILE       Use FILE which defines the job to evaluate
      --subset=SET          Evaluate SET which is a subset of Guix packages
  -I, --interval=N          Wait N seconds between each evaluation
  -V, --version             Display version
  -h, --help                Display this help message")
  (newline)
  (show-package-information))

(define %options
  `((file     (single-char #\f) (value #t))
    (subset   (value #t))
    (interval (single-char #\I) (value #t))
    (version  (single-char #\V) (value #f))
    (help     (single-char #\h) (value #f))))

(define %guix-repository
  (make-parameter "git://git.savannah.gnu.org/guix.git"))

(define* (pull-changes dir)
  "Get the latest version of Guix repository.  Clone repository in directory
DIR if required."
  (or (file-exists? dir) (mkdir dir))
  (with-directory-excursion dir
    (let ((guixdir "guix"))
      (or (file-exists? guixdir)
          (system* "git" "clone" (%guix-repository) guixdir))
      (with-directory-excursion guixdir
        (and (zero? (system* "git" "fetch")) ;no 'git pull' to avoid merges
             (zero? (system* "git" "reset" "--hard" "origin/master")))))))

(define (compile dir)
  "Compile files in Guix cloned repository in directory DIR."
  (with-directory-excursion (string-append dir "/guix")
    (or (file-exists? "configure") (system* "./bootstrap"))
    (or (file-exists? "Makefile")
        (system* "./configure" "--localstatedir=/var"))
    (zero? (system* "make" "-j" (number->string (current-processor-count))))))

(define %user-module
  ;; Cuirass user module.
  (let ((m (make-module)))
    (beautify-user-module! m)
    m))

(define (build-packages store jobs)
  "Build JOBS which is a list of <job> objects."
  (map (match-lambda
         (($ <job> name drv)
          (format #t "building ~A...~%" drv)
          ((guix-variable 'derivations 'build-derivations)
           store (list drv))
          (format #t "~A~%"
                  ((guix-variable 'derivations
                                  'derivation-path->output-path) drv))))
       jobs))

(define (evaluate store dir spec args)
  "Evaluate and build package derivations in directory DIR."
  (save-module-excursion
   (lambda ()
     (set-current-module %user-module)
     (let ((guixdir (string-append dir "/guix")))
       (format #t "prepending ~s to the load path~%" guixdir)
       (set! %load-path (cons guixdir %load-path)))
     (primitive-load spec)))
  (let ((job-specs ((module-ref %user-module 'hydra-jobs) store args)))
    (map (match-lambda
           (($ <job-spec> name thunk metadata)
            (format (current-error-port) "evaluating '~a'... " name)
            (force-output (current-error-port))
            (make-job name (call-with-time-display thunk) metadata)))
         job-specs)))


;;;
;;; Entry point.
;;;

(define* (main #:optional (args (command-line)))
  (let ((opts     (getopt-long args %options))
        (progname "cuirass"))
    (cond
     ((option-ref opts 'help #f)
      (show-help progname)
      (exit 0))
     ((option-ref opts 'version #f)
      (show-version progname)
      (exit 0))
     (else
      (let* ((store    ((guix-variable 'store 'open-connection)))
             (jobfile  (option-ref opts 'file "tests/gnu-system.scm"))
             (subset   (option-ref opts 'subset "all"))
             (args     (option-ref opts '() #f))
             (cachedir (if (null? args)
                           (getenv "CUIRASS_CACHEDIR")
                           (car args))))
        (dynamic-wind
          (const #t)
          (lambda ()
            (while #t
              (pull-changes cachedir)
              (compile cachedir)
              (let ((jobs (evaluate store cachedir jobfile
                                    (acons 'subset subset '()))))
                ((guix-variable 'store 'set-build-options) store
                 #:use-substitutes? #f)
                (build-packages store jobs))
              (sleep (string->number (option-ref opts 'interval "60")))))
          (lambda ()
            ((guix-variable 'store 'close-connection) store))))))))