mirror of https://notabug.org/mthl/cuirass.git
180 lines
7.0 KiB
Scheme
180 lines
7.0 KiB
Scheme
#!/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 "60")))
|
||
(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)))))))))))
|