guix-cuirass/bin/cuirass.in

#!/bin/sh
# -*- scheme -*-
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
!#
;;; cuirass -- continuous integration tool
;;; 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 config)
             (cuirass database)
             (cuirass ui)
             (cuirass utils)
             (guix derivations)
             (guix store)
             (ice-9 getopt-long)
             (ice-9 popen)
             (ice-9 rdelim))

(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
  -S  --specifications=SPECFILE
                            Add specifications from SPECFILE to database.
  -D  --database=DB         Use DB to store build results.
  -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
  '((one-shot                         (value #f))
    (cache-directory                  (value #t))
    (specifications (single-char #\S) (value #t))
    (database       (single-char #\D) (value #t))
    (interval       (single-char #\I) (value #t))
    (version        (single-char #\V) (value #f))
    (help           (single-char #\h) (value #f))))

(define (fetch-repository spec)
  "Get the latest version of repository specified in SPEC.  Clone repository
if required."
  (define (current-commit)
    (let* ((pipe   (open-input-pipe "git log -n1"))
           (log    (read-string pipe))
           (commit (cadr (string-split log char-set:whitespace))))
      (close-pipe pipe)
      commit))

  (let ((cachedir (%package-cachedir)))
    (or (file-exists? cachedir) (mkdir cachedir))
    (with-directory-excursion cachedir
      (let ((name   (assq-ref spec #:name))
            (url    (assq-ref spec #:url))
            (branch (assq-ref spec #:branch))
            (commit (assq-ref spec #:commit))
            (tag    (assq-ref spec #:tag)))
        (or (file-exists? name) (system* "git" "clone" url name))
        (with-directory-excursion name
          (and (zero? (system* "git" "fetch"))
               (zero? (system* "git" "reset" "--hard"
                               (or tag
                                   commit
                                   (string-append "origin/" branch))))
               (current-commit)))))))

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

(define (evaluate store db spec)
  "Evaluate and build package derivations.  Return a list of jobs."
  (let* ((port (open-pipe* OPEN_READ
                           "evaluate"
                           (string-append (%package-cachedir) "/"
                                          (assq-ref spec #:name) "/"
                                          (assq-ref spec #:load-path))
                           (%package-cachedir)
                           (object->string spec)
                           (%package-database)))
         (jobs (read port)))
    (close-pipe port)
    jobs))

(define (build-packages store db jobs)
  "Build JOBS and return a list of Build results."
  (map (λ (job)
         (let ((log-port (%make-void-port "w0"))
               (name     (assq-ref job #:job-name))
               (drv      (assq-ref job #:derivation)))
           (simple-format #t "building ~A...\n" drv)
           (parameterize ((current-build-output-port log-port))
             (build-derivations store (list drv))
             (let* ((output (derivation-path->output-path drv))
                    (log    (log-file store output))
                    (build  `((#:derivation . ,drv)
                              (#:log . ,log)
                              (#:output . ,output)))
                    (id     (db-add-build db build)))
               (close-port log-port)
               (simple-format #t "~A\n" output)
               (acons #:id id build)))))
       jobs))

(define (process-specs db jobspecs)
  "Evaluate and build JOBSPECS and store results in DB."
  (for-each (λ (spec)
              (let ((commit (fetch-repository spec))
                    (stamp  (db-get-stamp db spec)))
                (unless (string=? commit stamp)
                  (compile (string-append (%package-cachedir) "/"
                                          (assq-ref spec #:name)))
                  (with-store store
                    (let ((jobs (evaluate store db spec)))
                      (set-build-options store #:use-substitutes? #f)
                      (build-packages store db jobs))))
                (db-add-stamp db spec commit)))
            jobspecs))

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

(define* (main #:optional (args (command-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))))
      (cond
       ((option-ref opts 'help #f)
        (show-help)
        (exit 0))
       ((option-ref opts 'version #f)
        (show-version)
        (exit 0))
       (else
        (let ((one-shot? (option-ref opts 'one-shot #f))
              (interval  (string->number (option-ref opts 'interval "10")))
              (specfile  (option-ref opts 'specifications #f)))
          (with-database db
            (and specfile
                 (let ((new-specs (save-module-excursion
                                   (λ ()
                                     (set-current-module (make-user-module))
                                     (primitive-load specfile)))))
                   (for-each (λ (spec) (db-add-specification db spec))
                             new-specs)))
            (let ((specs (db-get-specifications db)))
              (if one-shot?
                  (process-specs db specs)
                  (while #t
                    (process-specs db specs)
                    (sleep interval)))))))))))