2
0
Fork 0
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git synced 2023-12-14 06:03:04 +01:00
guix-cuirass/bin/cuirass.in

156 lines
5.9 KiB
Text
Raw Normal View History

2016-05-11 19:59:47 +02:00
#!/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)
(ice-9 getopt-long))
2016-05-11 19:59:47 +02:00
(define* (show-help)
(simple-format #t "Usage: ~a [OPTIONS] [CACHEDIR]" (%program-name))
(display "
Run Guix job from a git repository cloned in CACHEDIR.
-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
`((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))))
2016-05-11 19:59:47 +02:00
(define %user-module
;; Cuirass user module.
(let ((m (make-module)))
(beautify-user-module! m)
m))
2016-06-15 15:30:15 +02:00
(define (fetch-repository cachedir spec)
"Get the latest version of Guix repository. Clone repository in directory
DIR if required."
(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)))))))))
2016-06-15 15:30:15 +02:00
(define (evaluate store db cachedir spec)
"Evaluate and build package derivations. Return a list a jobs."
2016-06-15 15:30:15 +02:00
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(let ((dir (string-append cachedir "/" (job-spec-name spec))))
(format #t "prepending ~s to the load path~%" dir)
(set! %load-path (cons dir %load-path)))
(primitive-load (job-spec-file spec))))
(let* ((proc (module-ref %user-module (job-spec-proc spec)))
(jobs (proc store (job-spec-arguments spec))))
2016-06-29 16:16:48 +02:00
(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)))
2016-06-15 15:30:15 +02:00
2016-06-29 16:16:48 +02:00
(define (build-packages store db jobs)
"Build JOBS which is a list of <job> objects."
2016-06-29 16:16:48 +02:00
(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 (lambda (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)))
2016-05-11 19:59:47 +02:00
;;;
;;; 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))))
(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))
(args (option-ref opts '() #f))
(cachedir (if (null? args)
(getenv "CUIRASS_CACHEDIR")
(car args))))
(with-database db
(while #t
(for-each
(λ (spec)
(fetch-repository cachedir spec)
(let ((store ((guix-variable 'store 'open-connection))))
(dynamic-wind
(const #t)
(lambda ()
2016-06-29 16:16:48 +02:00
(let ((jobs (evaluate store db cachedir spec))
(set-build-options
(guix-variable 'store 'set-build-options)))
(set-build-options store #:use-substitutes? #f)
2016-06-29 16:16:48 +02:00
(build-packages store db jobs)))
(lambda ()
((guix-variable 'store 'close-connection) store)))))
specs)
(sleep (string->number interval))))))))))