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 config)
             (cuirass base)
             (cuirass database)
             (cuirass job)
             (cuirass ui)
             (cuirass utils)
             (ice-9 getopt-long))

(define* (show-help)
  (simple-format #t "Usage: ~a [OPTIONS] ~%" (%program-name))
  (display "Run build jobs.

      --cache-directory=DIR Use DIR for storing repository data
  -f  --use-file=FILE       Use FILE which defines the job to evaluate
  -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
  `((cache-directory            (value #t))
    (file     (single-char #\f) (value #t))
    (database (single-char #\f) (value #t))
    (interval (single-char #\I) (value #t))
    (version  (single-char #\V) (value #f))
    (help     (single-char #\h) (value #f))))

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

(define (fetch-repository spec)
  "Get the latest version of repository specified in SPEC.  Clone repository
if required."
  (let ((cachedir (%package-cachedir)))
    (or (file-exists? cachedir) (mkdir cachedir))
    (with-directory-excursion cachedir
      (let ((name   (job-spec-name spec))
            (url    (job-spec-url spec))
            (branch (job-spec-branch spec))
            (commit (job-spec-commit spec))
            (tag    (job-spec-tag spec)))
        (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))))))))))

(define (set-load-path! spec)
  "Set %LOAD-PATH to match what is specified in SPEC."
  (let* ((name (job-spec-name spec))
         (path (job-spec-load-path spec))
         (dir  (string-join (list (%package-cachedir) name path) "/")))
    (format #t "prepending ~s to the load path~%" dir)
    (set! %load-path (cons dir %load-path))))

(define (evaluate store db spec)
  "Evaluate and build package derivations.  Return a list a jobs."
  (save-module-excursion
   (λ ()
     (set-current-module %user-module)
     ;; Handle both relative and absolute file names for SPEC-FILE.
     (with-directory-excursion
         (string-append (%package-cachedir) "/" (job-spec-name spec))
       (primitive-load (job-spec-file spec)))))
  (let* ((proc (module-ref %user-module (job-spec-proc spec)))
         (jobs (proc store (job-spec-arguments spec))))
    (map (λ (job)
           (let ((id (db-add-evaluation db job)))
             (make-job #:name (job-name job)
                       #:derivation (job-derivation job)
                       #:metadata (acons 'id id (job-metadata job)))))
         jobs)))

(define (build-packages store db jobs)
  "Build JOBS which is a list of <job> objects."
  (let ((build-derivations (guix-variable 'derivations 'build-derivations))
        (current-build-output-port
         (guix-variable 'store 'current-build-output-port))
        (derivation-path->output-path
         (guix-variable 'derivations 'derivation-path->output-path)))
    (map (λ (job)
           (let ((log-port (tmpfile))
                 (name     (job-name job))
                 (drv      (job-derivation job)))
             (setvbuf log-port _IOLBF)
             (format #t "building ~A...~%" drv)
             (parameterize ((current-build-output-port log-port))
               (build-derivations store (list drv))
               (db-add-build-log db job log-port)
               (close-port log-port))
             (format #t "~A~%" (derivation-path->output-path drv))))
         jobs)))


;;;
;;; 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* ((specfile (option-ref opts 'file "tests/hello-subset.scm"))
               (interval (option-ref opts 'interval "60"))
               (specs    (primitive-load specfile)))
          (with-database db
            (while #t
              (for-each
               (λ (spec)
                 (fetch-repository spec)
                 (let ((old-path %load-path))
                   (and (job-spec-load-path spec)
                        (set-load-path! spec))
                   (let ((store ((guix-variable 'store 'open-connection))))
                     (dynamic-wind
                       (const #t)
                       (λ ()
                         (let ((jobs (evaluate store db spec))
                               (set-build-options
                                (guix-variable 'store 'set-build-options)))
                           (set-build-options store #:use-substitutes? #f)
                           (build-packages store db jobs)))
                       (λ ()
                         ((guix-variable 'store 'close-connection) store)
                         (set! %load-path old-path))))))
               specs)
              (sleep (string->number interval))))))))))