mirrors
/
cuirass
mirror of https://notabug.org/mthl/cuirass.git
1
0
Fork 0
Code Issues Releases Wiki Activity

Compare commits

base: mirrors:master
Branches Tags
mirrors:improve-build-parallelism
mirrors:master
mirrors:v0.0.1
..
compare: mirrors:v0.0.1
Branches Tags
mirrors:improve-build-parallelism
mirrors:master
mirrors:v0.0.1

No commits in common. "master" and "v0.0.1" have entirely different histories.
master ... v0.0.1

35 changed files with 168 additions and 3364 deletions
Show Stats Expand all files Collapse all files

26
.dir-locals.el
View File

@ -1,19 +1,11 @@
;;; Directory Local Variables
;;; For more information see (info "(emacs) Directory Variables")
;; Per-directory local variables for GNU Emacs 23 and later.
((nil
(fill-column . 78)
(tab-width . 8)
(bug-reference-url-format . "http://bugs.gnu.org/%s")
(bug-reference-bug-regexp
. "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>"))
(scheme-mode
(indent-tabs-mode)
(eval put 'call-with-time 'scheme-indent-function 1)
(eval put 'test-error 'scheme-indent-function 1)
(eval put 'make-parameter 'scheme-indent-function 1)
(eval put 'with-database 'scheme-indent-function 1))
(texinfo-mode
(indent-tabs-mode)
(fill-column . 72)
(ispell-local-dictionary . "american")))
. ((fill-column . 78)
(tab-width . 8)
;; For use with 'bug-reference-prog-mode'.
(bug-reference-url-format . "http://bugs.gnu.org/%s")
(bug-reference-bug-regexp
. "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>")))
(scheme-mode . ((indent-tabs-mode . nil))))

15
.gitignore vendored
View File

@ -1,27 +1,18 @@
*.go
*.info
*.log
*.trs
.dirstamp
/*.status
/INSTALL
/aclocal.m4
/autom4te.cache/
/bin/cuirass
/bin/evaluate
/build-aux/config.guess
/build-aux/config.sub
/build-aux/install-sh
/build-aux/mdate-sh
/build-aux/missing
/build-aux/test-driver
/build-aux/texinfo.tex
/cache/
/config.cache
/configure
/doc/version.texi
/src/cuirass/config.scm
Makefile
Makefile.in
pre-inst-env
stamp-vti
/bin/cuirass
/config.cache
/cache/

171
Makefile.am
View File

@ -1,74 +1,27 @@
## Process this file with automake to produce Makefile.in.
# Copyright © 1995-2016 Free Software Foundation, Inc.
# Copyright © 2016, 2017 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, 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/>.
bin_SCRIPTS = bin/cuirass bin/evaluate
bin_SCRIPTS = bin/cuirass
noinst_SCRIPTS = pre-inst-env
guilesitedir = $(datarootdir)/guile/site/2.0
dist_guilesite_DATA = src/cuirass.scm
nodist_guilesite_DATA = $(dist_guilesite_DATA:.scm=.go)
dist_pkgmodule_DATA = src/cuirass/base.scm
nodist_pkgmodule_DATA = $(dist_pkgmodule_DATA:%.scm=%.go)
pkgmoduledir = $(guilesitedir)/$(PACKAGE)
dist_pkgmodule_DATA = \
src/cuirass/base.scm \
src/cuirass/database.scm \
src/cuirass/http.scm \
src/cuirass/repo.scm \
src/cuirass/ui.scm \
src/cuirass/utils.scm
nodist_pkgmodule_DATA = \
$(dist_pkgmodule_DATA:.scm=.go) \
src/cuirass/config.scm \
src/cuirass/config.go
dist_pkgdata_DATA = src/schema.sql
TEST_EXTENSIONS = .scm .sh
AM_TESTS_ENVIRONMENT = \
env GUILE_AUTO_COMPILE='0' \
testsrcdir='$(abs_top_srcdir)/tests' \
testbuilddir='$(abs_top_builddir)/tests'
TEST_EXTENSIONS = .scm
AM_TESTS_ENVIRONMENT = env GUILE_AUTO_COMPILE='0'
SCM_LOG_DRIVER = \
$(builddir)/pre-inst-env $(GUILE) \
$(srcdir)/build-aux/test-driver.scm
SH_LOG_COMPILER = $(top_builddir)/pre-inst-env $(SHELL)
AM_SH_LOG_FLAGS = -x -e
TESTS = \
tests/base.scm \
## tests/basic.sh # takes too long to execute
tests/database.scm \
tests/http.scm \
tests/repo.scm \
tests/ui.scm \
tests/utils.scm
TESTS = tests/base.scm
# Unset 'GUILE_LOAD_COMPILED_PATH' altogether while compiling. Otherwise, if
# $GUILE_LOAD_COMPILED_PATH contains $(pkgmoduledir), we may find .go files in
# there that are newer than the local .scm files (for instance because the
# user ran 'make install' recently). When that happens, we end up loading
# those previously-installed .go files, which may be stale, thereby breaking
# the whole thing. Set GUILE_AUTO_COMPILE to 0 to avoid auto-compiling guild.
# $GUILE_LOAD_COMPILED_PATH contains $(cuirassmoduledir), we may find .go
# files in there that are newer than the local .scm files (for instance
# because the user ran 'make install' recently). When that happens, we end up
# loading those previously-installed .go files, which may be stale, thereby
# breaking the whole thing. Set GUILE_AUTO_COMPILE to 0 to avoid
# auto-compiling guild.
#
# XXX: Use the C locale for when Guile lacks
# <http://git.sv.gnu.org/cgit/guile.git/commit/?h=stable-2.0&id=e2c6bf3866d1186c60bacfbd4fe5037087ee5e3f>.
@ -82,32 +35,7 @@ TESTS = \
--warn=format --warn=unbound-variable --warn=arity-mismatch \
--target="$(host)" --output="$@" "$<" $(devnull_verbose)
CLEANFILES = \
$(nodist_guilesite_DATA) \
$(dist_pkgmodule_DATA:.scm=.go) \
src/cuirass/config.go
.PHONY: sql-check
sql-check: src/schema.sql
@echo "$<"
$(AM_V_at)sqlite3 tmp-$$$.db < $< ; \
rm tmp-$$$.db
## -------------- ##
## Distribution. ##
## -------------- ##
EXTRA_DIST = \
.dir-locals.el \
bin/cuirass.in \
bin/evaluate.in \
bootstrap \
build-aux/guix.scm \
src/cuirass/config.scm.in \
$(TESTS)
dist-hook: gen-ChangeLog
$(AM_V_GEN)echo $(VERSION) > $(distdir)/.tarball-version
.PHONY: gen-ChangeLog
gen-ChangeLog:
@ -122,78 +50,11 @@ gen-ChangeLog:
mv $(distdir)/cl-t $(distdir)/ChangeLog; } \
fi
## ----------------- ##
## Generated files. ##
## ----------------- ##
EXTRA_DIST = \
.dir-locals.el \
$(TESTS)
# 'AC_CONFIG_FILES' doesn't fully expand variables that depend on ${prefix}.
# To use such variables in source files and scripts while following GNU Coding
# Standards, let 'make' manage their replacement.
# Use config.status to substitute the remainder where a single expansion is
# sufficient. We use a funny notation here to avoid configure substitutions
# in our text.
do_subst = ( $(SED) \
-e "s,@configure_input[@],Generated from $$in. Do not edit by hand.,g" \
-e 's,@datadir[@],$(datadir),g' \
-e 's,@GUILE[@],$(GUILE),g' \
-e 's,@localstatedir[@],$(localstatedir),g' \
-e 's,@PACKAGE_LOAD_COMPILED_PATH[@],$(guilesitedir),g' \
-e 's,@PACKAGE_LOAD_PATH[@],$(guilesitedir),g' \
| $(SHELL) ./config.status --file=- )
# Generic instructions to perform the substitution. Generated files shouldn't
# contain unexpanded '@substitutions@', and should be made read-only, to
# prevent them from being edited by mistake instead of the file they are
# generated from.
generate_file = \
$(AM_V_GEN)rm -f $@ $@-t; \
$(MKDIR_P) $(@D); \
in=$@.in && $(do_subst) <$(srcdir)/$$in >$@-t; \
if LC_ALL=C grep '@[a-zA-Z0-9_][a-zA-Z0-9_]*@' $@-t; then \
echo "$@ contains unexpanded substitution (see lines above)"; \
exit 1; \
fi; \
chmod a-w $@-t; mv -f $@-t $@
# These files depend on Makefile so they are rebuilt if $(VERSION),
# $(datadir) or other do_subst'ituted variables change.
bin/cuirass: $(srcdir)/bin/cuirass.in
bin/evaluate: $(srcdir)/bin/evaluate.in
$(bin_SCRIPTS): Makefile
$(generate_file); chmod +x $@
src/cuirass/config.scm: $(srcdir)/src/cuirass/config.scm.in Makefile
$(generate_file)
# Guile modules require 'src/cuirass/config.scm' to exist before their
# compilation.
BUILT_SOURCES = src/cuirass/config.scm
MOSTLYCLEANFILES = $(bin_SCRIPTS) src/cuirass/config.scm
## --------------- ##
## Documentation. ##
## --------------- ##
info_TEXINFOS = doc/cuirass.texi
doc_cuirass_TEXINFOS = doc/fdl-1.3.texi
# Install the examples.
nobase_dist_pkgdata_DATA = \
examples/gnu-system.scm \
examples/guix-jobs.scm \
examples/hello-singleton.scm \
examples/hello-subset.scm
## -------------- ##
## Installation. ##
## -------------- ##
# Ensure that the scripts will find their module directories.
install-exec-hook:
$(SED) \
-e 's,^#GUILE_LOAD,GUILE_LOAD,g' \
-i $(DESTDIR)$(bindir)/cuirass
CLEANFILES = $(nodist_pkgmodule_DATA)
## -------------- ##
## Silent rules. ##

63
README
View File

@ -1,63 +1,10 @@
Cuirass is a continuous integration tool using GNU Guix. It is intended as a
replacement for Hydra.
Cuirass is continuous integration system using GNU Guix. It is
intended as replacement for Hydra.
Requirements
============
Cuirass currently depends on the following packages:
GNU Guix must be installed along with all its development dependencies
as described here:
- GNU Guile 2.0.9 or later
- GNU Guix (and all its development dependencies)
- GNU Make
- Guile-JSON
- Guile-SQLite3
- Git
A convenient way to install those dependencies is to install Guix and execute
the following command:
$ guix environment -l build-aux/guix.scm
This will build and enter an environment which provides all the necessary
dependencies.
Build Instructions
==================
When all the dependencies are available on you system, in order to build and
install Cuirass, you can proceed with the usual:
$ ./configure && sudo make install
An alternative way is to directly install Cuirass in your Guix profile, using:
$ guix package -f build-aux/guix.scm
To build it, but not install it, run:
$ guix build -f build-aux/guix.scm
Example
=======
A quick way to manually test Cuirass is to execute:
./pre-inst-env cuirass --specifications=examples/hello-singleton.scm --database=test.db
This will read the file "examples/hello-singleton.scm" which contains a list of
specifications and add them to the database "test.db" which is created if it
doesn't already exist.
'cuirass' then loops evaluating/building the specs. The database keeps track
of the specifications in order to allow users to accumulate specifications.
To resume the evaluation/build process you can execute the same command
without the '--specifications' option:
./pre-inst-env cuirass --database=test.db
Contributing
============
See the manual for useful hacking informations, by running
info -f doc/cuirass.info "Contributing"
https://www.gnu.org/software/guix/manual/html_node/Building-from-Git.html#Building-from-Git

158
bin/cuirass.in
View File

@ -1,63 +1,90 @@
#!/bin/sh
# -*- scheme -*-
# @configure_input@
#GUILE_LOAD_PATH="@PACKAGE_LOAD_PATH@${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
#GUILE_LOAD_COMPILED_PATH="@PACKAGE_LOAD_COMPILED_PATH@${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
!#
;;;; cuirass -- continuous integration tool
;;;; cuirass - continuous integration system
;;;
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 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
;;; 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)
(cuirass ui)
(cuirass utils)
(ice-9 getopt-long))
(use-modules (cuirass base)
(ice-9 match))
(define (show-help)
(format #t "Usage: ~a [OPTIONS]~%" (%program-name))
(display "Run build jobs from internal database.
(define %guix-repository
(make-parameter "git://git.savannah.gnu.org/guix.git"))
--one-shot Evaluate and build jobs only once
--cache-directory=DIR Use DIR for storing repository data
-L --load-path=DIR Prepend DIR to Guix package module search path.
-S --specifications=SPECFILE
Add specifications from SPECFILE to database.
-D --database=DB Use DB to store build results.
-p --port=NUM Port of the HTTP server.
-I, --interval=N Wait N seconds between each poll
--use-substitutes Allow usage of pre-built substitutes
-V, --version Display version
-h, --help Display this help message")
(newline)
(show-package-information))
(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 %options
'((one-shot (value #f))
(cache-directory (value #t))
(load-path (single-char #\L) (value #t))
(specifications (single-char #\S) (value #t))
(database (single-char #\D) (value #t))
(port (single-char #\p) (value #t))
(interval (single-char #\I) (value #t))
(use-substitutes (value #f))
(version (single-char #\V) (value #f))
(help (single-char #\h) (value #f))))
(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. ((job-symbol pair ...) ...)"
(map (lambda (thing)
(let ((name (symbol->string (car thing)))
(drv (cdadr thing)))
(format #t "building ~A => ~A~%" name drv)
((guix-variable 'derivations 'build-derivations) store (list drv))))
jobs))
(define (evaluate dir)
"Evaluate and build package derivations in directory DIR."
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(primitive-load (string-append dir "/guix/build-aux/hydra/gnu-system.scm"))))
(let ((store ((guix-variable 'store 'open-connection))))
(dynamic-wind
(const #t)
(lambda ()
((guix-variable 'store 'set-build-options) store
#:use-substitutes? #f)
(build-packages
store
(match ((module-ref %user-module 'hydra-jobs) store '())
(((names . thunks) ...)
(map (lambda (job thunk)
(format (current-error-port) "evaluating '~a'... " job)
(force-output (current-error-port))
(cons job (call-with-time-display thunk)))
names thunks)))))
(lambda ()
((guix-variable 'store 'close-connection) store)))))
;;;
@ -65,41 +92,12 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
;;;
(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)))
(%guix-package-path
(option-ref opts 'load-path (%guix-package-path)))
(%use-substitutes? (option-ref opts 'use-substitutes #f)))
(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))
(port (string->number (option-ref opts 'port "8080")))
(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)))
(if one-shot?
(process-specs db (db-get-specifications db))
(begin
(call-with-new-thread
(λ ()
(while #t
(process-specs db (db-get-specifications db))
(sleep interval))))
(run-cuirass-server db #:port port))))))))))
(match args
((program interval)
(let ((cachedir (getenv "CUIRASS_CACHEDIR")))
(while #t
(pull-changes cachedir)
(compile cachedir)
(evaluate cachedir)
(sleep (string->number interval)))))
(_ (main (list (car args) "60")))))

87
bin/evaluate.in
View File

@ -1,87 +0,0 @@
#!/bin/sh
# -*- scheme -*-
# @configure_input@
GUILE_LOAD_PATH="$1${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
export GUILE_LOAD_PATH
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
!#
;;;; evaluate -- convert a specification to a job list
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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)
(cuirass utils)
(ice-9 match)
(ice-9 pretty-print)
(guix store))
(define* (main #:optional (args (command-line)))
(match args
((command load-path guix-package-path cachedir specstr database)
;; Load FILE, a Scheme file that defines Hydra jobs.
(let ((%user-module (make-fresh-user-module))
(spec (with-input-from-string specstr read))
(stdout (current-output-port))
(stderr (current-error-port)))
(save-module-excursion
(λ ()
(set-current-module %user-module)
(with-directory-excursion
(string-append cachedir "/" (assq-ref spec #:name))
(primitive-load (assq-ref spec #:file)))))
(with-store store
(unless (assoc-ref spec #:use-substitutes?)
;; Make sure we don't resort to substitutes.
(set-build-options store #:use-substitutes? #f #:substitute-urls '()))
;; Grafts can trigger early builds. We do not want that to happen
;; during evaluation, so use a sledgehammer to catch such problems.
(set! build-things
(λ (store . args)
(display "error: trying to build things during evaluation!~%"
stderr)
(simple-format stderr "'build-things' arguments: ~S~%" args)
(exit 1)))
(parameterize ((%package-database database)
(%use-substitutes? (assoc-ref spec #:use-substitutes?)))
(unless (string-null? guix-package-path)
(set-guix-package-path! guix-package-path))
;; Call the entry point of FILE and print the resulting job sexp.
(let* ((proc-name (assq-ref spec #:proc))
(proc (module-ref %user-module proc-name))
(thunks (proc store (assq-ref spec #:arguments)))
(db (db-open))
(commit (assq-ref spec #:current-commit))
(eval `((#:specification . ,(assq-ref spec #:name))
(#:revision . ,commit)))
(eval-id (db-add-evaluation db eval)))
(pretty-print
(map (λ (thunk)
(let* ((job (call-with-time-display thunk))
;; Keep track of SPEC id in the returned jobs.
(job* (acons #:eval-id eval-id job)))
(db-add-derivation db job*)
job*))
thunks)
stdout)
(db-close db))))))
((command _ ...)
(simple-format (current-error-port) "Usage: ~A FILE
Evaluate the Hydra jobs defined in FILE.~%"
command)
(exit 1))))

5
bootstrap
View File

@ -1,5 +0,0 @@
#!/bin/sh
# Initialize the build system.
set -e -x
exec autoreconf -vfi

226
build-aux/git-version-gen
View File

@ -1,226 +0,0 @@
#!/bin/sh
# Print a version string.
scriptversion=2016-12-25.10; # UTC
# Copyright (C) 2007-2016 Free Software Foundation, Inc.
#
# This program 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.
#
# This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
# This script is derived from GIT-VERSION-GEN from GIT: http://git.or.cz/.
# It may be run two ways:
# - from a git repository in which the "git describe" command below
# produces useful output (thus requiring at least one signed tag)
# - from a non-git-repo directory containing a .tarball-version file, which
# presumes this script is invoked like "./git-version-gen .tarball-version".
# In order to use intra-version strings in your project, you will need two
# separate generated version string files:
#
# .tarball-version - present only in a distribution tarball, and not in
# a checked-out repository. Created with contents that were learned at
# the last time autoconf was run, and used by git-version-gen. Must not
# be present in either $(srcdir) or $(builddir) for git-version-gen to
# give accurate answers during normal development with a checked out tree,
# but must be present in a tarball when there is no version control system.
# Therefore, it cannot be used in any dependencies. GNUmakefile has
# hooks to force a reconfigure at distribution time to get the value
# correct, without penalizing normal development with extra reconfigures.
#
# .version - present in a checked-out repository and in a distribution
# tarball. Usable in dependencies, particularly for files that don't
# want to depend on config.h but do want to track version changes.
# Delete this file prior to any autoconf run where you want to rebuild
# files to pick up a version string change; and leave it stale to
# minimize rebuild time after unrelated changes to configure sources.
#
# As with any generated file in a VC'd directory, you should add
# /.version to .gitignore, so that you don't accidentally commit it.
# .tarball-version is never generated in a VC'd directory, so needn't
# be listed there.
#
# Use the following line in your configure.ac, so that $(VERSION) will
# automatically be up-to-date each time configure is run (and note that
# since configure.ac no longer includes a version string, Makefile rules
# should not depend on configure.ac for version updates).
#
# AC_INIT([GNU project],
# m4_esyscmd([build-aux/git-version-gen .tarball-version]),
# [bug-project@example])
#
# Then use the following lines in your Makefile.am, so that .version
# will be present for dependencies, and so that .version and
# .tarball-version will exist in distribution tarballs.
#
# EXTRA_DIST = $(top_srcdir)/.version
# BUILT_SOURCES = $(top_srcdir)/.version
# $(top_srcdir)/.version:
# echo $(VERSION) > $@-t && mv $@-t $@
# dist-hook:
# echo $(VERSION) > $(distdir)/.tarball-version
me=$0
version="git-version-gen $scriptversion
Copyright 2011 Free Software Foundation, Inc.
There is NO warranty. You may redistribute this software
under the terms of the GNU General Public License.
For more information about these matters, see the files named COPYING."
usage="\
Usage: $me [OPTION]... \$srcdir/.tarball-version [TAG-NORMALIZATION-SED-SCRIPT]
Print a version string.
Options:
--prefix PREFIX prefix of git tags (default 'v')
--fallback VERSION
fallback version to use if \"git --version\" fails
--help display this help and exit
--version output version information and exit
Running without arguments will suffice in most cases."
prefix=v
fallback=
while test $# -gt 0; do
case $1 in
--help) echo "$usage"; exit 0;;
--version) echo "$version"; exit 0;;
--prefix) shift; prefix=${1?};;
--fallback) shift; fallback=${1?};;
-*)
echo "$0: Unknown option '$1'." >&2
echo "$0: Try '--help' for more information." >&2
exit 1;;
*)
if test "x$tarball_version_file" = x; then
tarball_version_file="$1"
elif test "x$tag_sed_script" = x; then
tag_sed_script="$1"
else
echo "$0: extra non-option argument '$1'." >&2
exit 1
fi;;
esac
shift
done
if test "x$tarball_version_file" = x; then
echo "$usage"
exit 1
fi
tag_sed_script="${tag_sed_script:-s/x/x/}"
nl='
'
# Avoid meddling by environment variable of the same name.
v=
v_from_git=
# First see if there is a tarball-only version file.
# then try "git describe", then default.
if test -f $tarball_version_file
then
v=`cat $tarball_version_file` || v=
case $v in
*$nl*) v= ;; # reject multi-line output
[0-9]*) ;;
*) v= ;;
esac
test "x$v" = x \
&& echo "$0: WARNING: $tarball_version_file is missing or damaged" 1>&2
fi
if test "x$v" != x
then
: # use $v
# Otherwise, if there is at least one git commit involving the working
# directory, and "git describe" output looks sensible, use that to
# derive a version string.
elif test "`git log -1 --pretty=format:x . 2>&1`" = x \
&& v=`git describe --abbrev=4 --match="$prefix*" HEAD 2>/dev/null \
|| git describe --abbrev=4 HEAD 2>/dev/null` \
&& v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
&& case $v in
$prefix[0-9]*) ;;
*) (exit 1) ;;
esac
then
# Is this a new git that lists number of commits since the last
# tag or the previous older version that did not?
# Newer: v6.10-77-g0f8faeb
# Older: v6.10-g0f8faeb
case $v in
*-*-*) : git describe is okay three part flavor ;;
*-*)
: git describe is older two part flavor
# Recreate the number of commits and rewrite such that the
# result is the same as if we were using the newer version
# of git describe.
vtag=`echo "$v" | sed 's/-.*//'`
commit_list=`git rev-list "$vtag"..HEAD 2>/dev/null` \
|| { commit_list=failed;
echo "$0: WARNING: git rev-list failed" 1>&2; }
numcommits=`echo "$commit_list" | wc -l`
v=`echo "$v" | sed "s/\(.*\)-\(.*\)/\1-$numcommits-\2/"`;
test "$commit_list" = failed && v=UNKNOWN
;;
esac
# Change the first '-' to a '.', so version-comparing tools work properly.
# Remove the "g" in git describe's output string, to save a byte.
v=`echo "$v" | sed 's/-/./;s/\(.*\)-g/\1-/'`;
v_from_git=1
elif test "x$fallback" = x || git --version >/dev/null 2>&1; then
v=UNKNOWN
else
v=$fallback
fi
v=`echo "$v" |sed "s/^$prefix//"`
# Test whether to append the "-dirty" suffix only if the version
# string we're using came from git. I.e., skip the test if it's "UNKNOWN"
# or if it came from .tarball-version.
if test "x$v_from_git" != x; then
# Don't declare a version "dirty" merely because a time stamp has changed.
git update-index --refresh > /dev/null 2>&1
dirty=`exec 2>/dev/null;git diff-index --name-only HEAD` || dirty=
case "$dirty" in
'') ;;
*) # Append the suffix only if there isn't one already.
case $v in
*-dirty) ;;
*) v="$v-dirty" ;;
esac ;;
esac
fi
# Omit the trailing newline, so that m4_esyscmd can use the result directly.
printf %s "$v"
# Local variables:
# eval: (add-hook 'write-file-hooks 'time-stamp)
# time-stamp-start: "scriptversion="
# time-stamp-format: "%:y-%02m-%02d.%02H"
# time-stamp-time-zone: "UTC0"
# time-stamp-end: "; # UTC"
# End:

96
build-aux/guix.scm
View File

@ -1,96 +0,0 @@
;;;; guix.scm -- Guix package definition
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016, 2017 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 (ice-9 popen)
(ice-9 rdelim)
(gnu)
(guix)
(srfi srfi-1))
(define (keep-cuirass-file? file stat)
;; Return #t if FILE in Cuirass repository must be kept, #f otherwise. FILE
;; is an absolute file name and STAT is the result of 'lstat' applied to
;; FILE.
(not (or (any (λ (str) (string-contains file str))
'(".git" "autom4te" "Makefile.in" ".go" ".log"
"stamp-vti" ".dirstamp"))
(any (λ (str) (string-suffix? str file))
'("trs""configure" "Makefile" "config.status" "pre-inst-env"
"aclocal.m4" "bin/cuirass" "bin/evaluate" "config.cache"
"guix.scm")))))
(define %aux-dir
(current-source-directory))
(define %srcdir
(dirname %aux-dir))
(define (git-version-gen)
;; Return a string containing Cuirass version number.
(let* ((cmd "git-version-gen .tarball-version")
(port (open-input-pipe (string-append %aux-dir "/" cmd)))
(str (read-line port)))
(close-pipe port)
str))
(define (spec+package-list spec)
(list spec (specification->package spec)))
(package
(inherit (specification->package "cuirass"))
(version (git-version-gen))
(source (local-file %srcdir #:recursive? #t
#:select? keep-cuirass-file?))
(arguments
'(#:phases
(modify-phases %standard-phases
(add-after 'unpack 'disable-repo-tests
;; Disable tests that use a connection to the Guix daemon.
(λ _
(substitute* "Makefile.am"
(("tests/repo.scm \\\\") "\\"))
#t))
(add-before 'configure 'bootstrap
(λ _ (zero? (system* "sh" "bootstrap"))))
(add-after 'install 'wrap-program
(lambda* (#:key inputs outputs #:allow-other-keys)
;; Wrap the 'cuirass' command to refer to the right modules.
(let* ((out (assoc-ref outputs "out"))
(json (assoc-ref inputs "guile-json"))
(sqlite (assoc-ref inputs "guile-sqlite3"))
(guix (assoc-ref inputs "guix"))
(mods (string-append json "/share/guile/site/2.0:"
sqlite "/share/guile/site/2.0:"
guix "/share/guile/site/2.0")))
(wrap-program (string-append out "/bin/cuirass")
`("GUILE_LOAD_PATH" ":" prefix (,mods))
`("GUILE_LOAD_COMPILED_PATH" ":" prefix (,mods)))))))))
(inputs
(map spec+package-list
'("guile@2.0"
"guile-json"
"guile-sqlite3"
"guix")))
(native-inputs
(map spec+package-list
'("autoconf"
"automake"
"bash"
"pkg-config"
"texinfo"))))

13
build-aux/pre-inst-env.in
View File

@ -22,12 +22,17 @@ abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`"
GUILE_LOAD_COMPILED_PATH="$abs_top_builddir/src${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
GUILE_LOAD_PATH="$abs_top_builddir/src:$abs_top_srcdir/src${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
CUIRASS_DATADIR="$abs_top_srcdir/src"
export CUIRASS_DATADIR
PATH="$abs_top_builddir/bin:$PATH"
export PATH
CUIRASS_CACHEDIR="$abs_top_builddir/cache"
export CUIRASS_CACHEDIR
# Append Guix cloned repository to Guile load paths.
guixdir="$CUIRASS_CACHEDIR/guix"
GUILE_LOAD_COMPILED_PATH="$guixdir:$GUILE_LOAD_COMPILED_PATH"
GUILE_LOAD_PATH="$guixdir:$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
exec "$@"

35
configure.ac
View File

@ -1,37 +1,12 @@
## Process this file with autoconf to produce a configure script.
# Copyright © 2016, 2017 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, 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/>.
AC_PREREQ([2.61])
AC_INIT([Cuirass],
m4_esyscmd([build-aux/git-version-gen .tarball-version]),
[bug-cuirass@framalistes.org], [cuirass],
[https://notabug.org/mthl/cuirass/])
AC_INIT([Cuirass], [0.0.1], [bug-guix@gnu.org])
AC_CONFIG_SRCDIR([bin/cuirass.in])
AC_CONFIG_AUX_DIR([build-aux])
AC_REQUIRE_AUX_FILE([git-version-gen])
AC_REQUIRE_AUX_FILE([test-driver.scm])
AM_INIT_AUTOMAKE([foreign subdir-objects -Wall])
AM_SILENT_RULES([yes]) # enables silent rules by default
AC_CANONICAL_HOST
AC_PROG_MKDIR_P
AC_PROG_SED
PKG_CHECK_MODULES([GUILE], [guile-2.0 >= 2.0.7])
AC_PATH_PROG([GUILE], [guile])
@ -39,11 +14,13 @@ AC_PATH_PROG([GUILD], [guild])
AS_IF([test -z "$ac_cv_path_GUILD"],
[AC_MSG_ERROR(['guild' program cannot be found.])])
GUILE_MODULE_REQUIRED([guix])
GUILE_MODULE_REQUIRED([json])
GUILE_MODULE_REQUIRED([sqlite3])
moduledir="${datarootdir}/guile/site/2.0"
pkgmoduledir="${moduledir}/cuirass"
AC_SUBST([moduledir])
AC_SUBST([pkgmoduledir])
AC_CONFIG_FILES([Makefile])
AC_CONFIG_FILES([bin/cuirass], [chmod +x bin/cuirass])
AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in],
[chmod +x pre-inst-env])
AC_OUTPUT

227
doc/cuirass.texi
View File

@ -1,227 +0,0 @@
\input texinfo
@setfilename cuirass.info
@documentencoding UTF-8
@include version.texi
@settitle Cuirass Reference Manual
@setchapternewpage odd
@copying
This manual is for Cuirass version @value{VERSION}, a build automation
server.
Copyright @copyright{} 2016, 2017 Mathieu Lirzin
@quotation
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
any later version published by the Free Software Foundation; with no
Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A
copy of the license is included in the section entitled ``GNU Free
Documentation License''.
@end quotation
@end copying
@dircategory Software development
@direntry
* Cuirass: (cuirass). Build automation server.
@end direntry
@titlepage
@title Cuirass Reference Manual
@subtitle Build automation server
@subtitle for version @value{VERSION}, @value{UPDATED}
@author by Mathieu Lirzin
@page
@vskip 0pt plus 1filll
@insertcopying
@end titlepage
@contents
@ifnottex
@node Top
@top Cuirass
@insertcopying
@end ifnottex
@c *********************************************************************
@menu
* Introduction:: What is Cuirass about?
Tutorial sections:
* Overview:: A quick tour of Cuirass
Reference sections:
* Invocation:: How to run Cuirass.
* Contributing:: Your help needed!
* GNU Free Documentation License:: The license of this manual.
* Concept Index:: Concepts.
@end menu
@c *********************************************************************
@node Introduction
@unnumbered Introduction
@cindex introduction
@dfn{Cuirass} is a general-purpose build automation server that checks
out source files from @acronym{VCS, Version Control System}
repositories, executes a @dfn{build job}, and notifies the results of
that job. A build job consists of a combinaison of tasks such as
compiling source code to binary code and running automated tests.
Notification is achieved by using a database that stores the build
results associated with an HTTP server that provides a convenient way to
access them.
Cuirass is inspired by the @url{https://nixos.org/hydra/, Hydra}
continuous build system. Unlike Hydra, it is built on top of the
@url{https://www.gnu.org/software/guix/, GNU Guix} functional package
manager.
The goal of Cuirass is to provide both on-demand, scheduled, and
triggered builds. A Build server is an important tool in the software
development process, because it allows modifying the source code while
ensuring the portability and robustness of those changes. It is the
basis of the @dfn{Continuous integration} practice.
@menu
* Continuous Integration:: A Software development practice
@end menu
@c *********************************************************************
@node Continuous Integration
@unnumberedsec Continuous Integration
@c *********************************************************************
@node Overview
@chapter Overview
@command{cuirass} acts as a daemon polling @acronym{VCS, version control
system} repositories for changes, and evaluating a derivation when
something has changed (@pxref{Derivations, Derivations,, guix, Guix}).
As a final step the derivation is realised and the result of that build
allows you to know if the job succeed or not.
What is actually done by @command{cuirass} is specified in a @dfn{job
specification} which is represented as an association list which is a
basic and traditional Scheme data structure. Here is an example of what
a specification might look like:
@lisp
`((#:name . "hello")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:branch . "master")
(#:no-compile? . #t)
(#:load-path . ".")
(#:proc . cuirass-jobs)
(#:file . "/tmp/drv-file.scm")
(#:arguments (subset . "hello")))
@end lisp
In this specification the keys are Scheme keywords which have the nice
property of being self evaluating. This means that they can't refer to
another value like symbols do.
Currently the only way to add those specifications to cuirass is to put
a list of them in a file and set the @code{--specifications} command
line option argument with the file name when launching the daemon
(@pxref{Invocation}). The specifications are persistent (they are kept
in a SQLite database) so the next time @command{cuirass} is run the
previously added specifications will remain active even if you don't
keep the @code{--specifications} option.
@c *********************************************************************
@node Invocation
@chapter Invoking cuirass
@cindex invoking cuirass
@cindex cuirass invocation
@cindex options for invoking cuirass
The usual way to invoke @code{cuirass} is as follows:
@example
cuirass --specifications @var{specs}
@end example
Additionally the following options can be used.
@table @code
@item --one-shot
Instead of executing @code{cuirass} as a daemon looping over the jobs.
Only evaluate and build the specifications once.
@item --cache-directory=@var{directory}
@var{directory} is the place where the VCS repositories used by the jobs
are stored.
@item --specifications=@var{specifications-file}
@itemx -S @var{specifications-file}
Add the specifications defined in @var{specifications-file} in the job
database before launching the evaluation and build processes.
@item --database=@var{database}
@itemx -D @var{database}
Use @var{database} as the database containing the jobs and the past
build results. Since @code{cuirass} uses SQLite as a database engine,
@var{database} must be a file name. If the file doesn't exist, it will
be created.
@item --port=@var{num}
@itemx -p @var{num}
Make the HTTP interface listen on port @var{num}. Use port 8080 by
default.
@item --interval=@var{n}
@itemx -I @var{n}
Wait @var{n} seconds between each poll.
@item --use-substitutes
This can be useful when you are not interested in building the
dependencies of a particular job.
@item --version
@itemx -V
Display the actual version of @code{cuirass}.
@item --help
@itemx -h
Display an help message that summarize all the options provided.
@end table
@c *********************************************************************
@node Contributing
@chapter Contributing
Everyone is welcome to contribute to Cuirass. You can report bugs, send
patches and share your ideas with others by sending emails the
@email{bug-cuirass@@framalistes.org, mailing list}.
Development is done using the Git distributed version control system.
Thus, access to the repository is not strictly necessary. We welcome
contributions in the form of patches as produced by @code{git
format-patch}. Please write commit logs in the ChangeLog format
(@pxref{Change Logs,,, standards, GNU Coding Standards}); you can check
the commit history for examples.
When posting a patch to the mailing list, use @samp{[PATCH] @dots{}} as
a subject. You may use your email client or the @command{git
send-email} command. We prefer to get patches in plain text messages,
either inline or as MIME attachments. You are advised to pay attention
if your email client changes anything like line breaks or indentation
which could potentially break the patches.
@c *********************************************************************
@node GNU Free Documentation License
@appendix GNU Free Documentation License
@cindex license, GNU Free Documentation License
@include fdl-1.3.texi
@c *********************************************************************
@node Concept Index
@unnumbered Concept Index
@printindex cp
@bye

505
doc/fdl-1.3.texi
View File

@ -1,505 +0,0 @@
@c The GNU Free Documentation License.
@center Version 1.3, 3 November 2008
@c This file is intended to be included within another document,
@c hence no sectioning command or @node.
@display
Copyright @copyright{} 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc.
@uref{http://fsf.org/}
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
@end display
@enumerate 0
@item
PREAMBLE
The purpose of this License is to make a manual, textbook, or other
functional and useful document @dfn{free} in the sense of freedom: to
assure everyone the effective freedom to copy and redistribute it,
with or without modifying it, either commercially or noncommercially.
Secondarily, this License preserves for the author and publisher a way
to get credit for their work, while not being considered responsible
for modifications made by others.
This License is a kind of ``copyleft'', which means that derivative
works of the document must themselves be free in the same sense. It
complements the GNU General Public License, which is a copyleft
license designed for free software.
We have designed this License in order to use it for manuals for free
software, because free software needs free documentation: a free
program should come with manuals providing the same freedoms that the
software does. But this License is not limited to software manuals;
it can be used for any textual work, regardless of subject matter or
whether it is published as a printed book. We recommend this License
principally for works whose purpose is instruction or reference.
@item
APPLICABILITY AND DEFINITIONS
This License applies to any manual or other work, in any medium, that
contains a notice placed by the copyright holder saying it can be
distributed under the terms of this License. Such a notice grants a
world-wide, royalty-free license, unlimited in duration, to use that
work under the conditions stated herein. The ``Document'', below,
refers to any such manual or work. Any member of the public is a
licensee, and is addressed as ``you''. You accept the license if you
copy, modify or distribute the work in a way requiring permission
under copyright law.
A ``Modified Version'' of the Document means any work containing the
Document or a portion of it, either copied verbatim, or with
modifications and/or translated into another language.
A ``Secondary Section'' is a named appendix or a front-matter section
of the Document that deals exclusively with the relationship of the
publishers or authors of the Document to the Document's overall
subject (or to related matters) and contains nothing that could fall
directly within that overall subject. (Thus, if the Document is in
part a textbook of mathematics, a Secondary Section may not explain
any mathematics.) The relationship could be a matter of historical
connection with the subject or with related matters, or of legal,
commercial, philosophical, ethical or political position regarding
them.
The ``Invariant Sections'' are certain Secondary Sections whose titles
are designated, as being those of Invariant Sections, in the notice
that says that the Document is released under this License. If a
section does not fit the above definition of Secondary then it is not
allowed to be designated as Invariant. The Document may contain zero
Invariant Sections. If the Document does not identify any Invariant
Sections then there are none.
The ``Cover Texts'' are certain short passages of text that are listed,
as Front-Cover Texts or Back-Cover Texts, in the notice that says that
the Document is released under this License. A Front-Cover Text may
be at most 5 words, and a Back-Cover Text may be at most 25 words.
A ``Transparent'' copy of the Document means a machine-readable copy,
represented in a format whose specification is available to the
general public, that is suitable for revising the document
straightforwardly with generic text editors or (for images composed of
pixels) generic paint programs or (for drawings) some widely available
drawing editor, and that is suitable for input to text formatters or
for automatic translation to a variety of formats suitable for input
to text formatters. A copy made in an otherwise Transparent file
format whose markup, or absence of markup, has been arranged to thwart
or discourage subsequent modification by readers is not Transparent.
An image format is not Transparent if used for any substantial amount
of text. A copy that is not ``Transparent'' is called ``Opaque''.
Examples of suitable formats for Transparent copies include plain
ASCII without markup, Texinfo input format, La@TeX{} input
format, SGML or XML using a publicly available
DTD, and standard-conforming simple HTML,
PostScript or PDF designed for human modification. Examples
of transparent image formats include PNG, XCF and
JPG@. Opaque formats include proprietary formats that can be
read and edited only by proprietary word processors, SGML or
XML for which the DTD and/or processing tools are
not generally available, and the machine-generated HTML,
PostScript or PDF produced by some word processors for
output purposes only.
The ``Title Page'' means, for a printed book, the title page itself,
plus such following pages as are needed to hold, legibly, the material
this License requires to appear in the title page. For works in
formats which do not have any title page as such, ``Title Page'' means
the text near the most prominent appearance of the work's title,
preceding the beginning of the body of the text.
The ``publisher'' means any person or entity that distributes copies
of the Document to the public.
A section ``Entitled XYZ'' means a named subunit of the Document whose
title either is precisely XYZ or contains XYZ in parentheses following
text that translates XYZ in another language. (Here XYZ stands for a
specific section name mentioned below, such as ``Acknowledgements'',
``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title''
of such a section when you modify the Document means that it remains a
section ``Entitled XYZ'' according to this definition.
The Document may include Warranty Disclaimers next to the notice which
states that this License applies to the Document. These Warranty
Disclaimers are considered to be included by reference in this
License, but only as regards disclaiming warranties: any other
implication that these Warranty Disclaimers may have is void and has
no effect on the meaning of this License.
@item
VERBATIM COPYING
You may copy and distribute the Document in any medium, either
commercially or noncommercially, provided that this License, the
copyright notices, and the license notice saying this License applies
to the Document are reproduced in all copies, and that you add no other
conditions whatsoever to those of this License. You may not use
technical measures to obstruct or control the reading or further
copying of the copies you make or distribute. However, you may accept
compensation in exchange for copies. If you distribute a large enough
number of copies you must also follow the conditions in section 3.
You may also lend copies, under the same conditions stated above, and
you may publicly display copies.
@item
COPYING IN QUANTITY
If you publish printed copies (or copies in media that commonly have
printed covers) of the Document, numbering more than 100, and the
Document's license notice requires Cover Texts, you must enclose the
copies in covers that carry, clearly and legibly, all these Cover
Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
the back cover. Both covers must also clearly and legibly identify
you as the publisher of these copies. The front cover must present
the full title with all words of the title equally prominent and
visible. You may add other material on the covers in addition.
Copying with changes limited to the covers, as long as they preserve
the title of the Document and satisfy these conditions, can be treated
as verbatim copying in other respects.
If the required texts for either cover are too voluminous to fit
legibly, you should put the first ones listed (as many as fit
reasonably) on the actual cover, and continue the rest onto adjacent
pages.
If you publish or distribute Opaque copies of the Document numbering
more than 100, you must either include a machine-readable Transparent
copy along with each Opaque copy, or state in or with each Opaque copy
a computer-network location from which the general network-using
public has access to download using public-standard network protocols
a complete Transparent copy of the Document, free of added material.
If you use the latter option, you must take reasonably prudent steps,
when you begin distribution of Opaque copies in quantity, to ensure
that this Transparent copy will remain thus accessible at the stated
location until at least one year after the last time you distribute an
Opaque copy (directly or through your agents or retailers) of that
edition to the public.
It is requested, but not required, that you contact the authors of the
Document well before redistributing any large number of copies, to give
them a chance to provide you with an updated version of the Document.
@item
MODIFICATIONS
You may copy and distribute a Modified Version of the Document under
the conditions of sections 2 and 3 above, provided that you release
the Modified Version under precisely this License, with the Modified
Version filling the role of the Document, thus licensing distribution
and modification of the Modified Version to whoever possesses a copy
of it. In addition, you must do these things in the Modified Version:
@enumerate A
@item
Use in the Title Page (and on the covers, if any) a title distinct
from that of the Document, and from those of previous versions
(which should, if there were any, be listed in the History section
of the Document). You may use the same title as a previous version
if the original publisher of that version gives permission.
@item
List on the Title Page, as authors, one or more persons or entities
responsible for authorship of the modifications in the Modified
Version, together with at least five of the principal authors of the
Document (all of its principal authors, if it has fewer than five),
unless they release you from this requirement.
@item
State on the Title page the name of the publisher of the
Modified Version, as the publisher.
@item
Preserve all the copyright notices of the Document.
@item
Add an appropriate copyright notice for your modifications
adjacent to the other copyright notices.
@item
Include, immediately after the copyright notices, a license notice
giving the public permission to use the Modified Version under the
terms of this License, in the form shown in the Addendum below.
@item
Preserve in that license notice the full lists of Invariant Sections
and required Cover Texts given in the Document's license notice.
@item
Include an unaltered copy of this License.
@item
Preserve the section Entitled ``History'', Preserve its Title, and add
to it an item stating at least the title, year, new authors, and
publisher of the Modified Version as given on the Title Page. If
there is no section Entitled ``History'' in the Document, create one
stating the title, year, authors, and publisher of the Document as
given on its Title Page, then add an item describing the Modified
Version as stated in the previous sentence.
@item
Preserve the network location, if any, given in the Document for
public access to a Transparent copy of the Document, and likewise
the network locations given in the Document for previous versions
it was based on. These may be placed in the ``History'' section.
You may omit a network location for a work that was published at
least four years before the Document itself, or if the original
publisher of the version it refers to gives permission.
@item
For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve
the Title of the section, and preserve in the section all the
substance and tone of each of the contributor acknowledgements and/or
dedications given therein.
@item
Preserve all the Invariant Sections of the Document,
unaltered in their text and in their titles. Section numbers
or the equivalent are not considered part of the section titles.
@item
Delete any section Entitled ``Endorsements''. Such a section
may not be included in the Modified Version.
@item
Do not retitle any existing section to be Entitled ``Endorsements'' or
to conflict in title with any Invariant Section.
@item
Preserve any Warranty Disclaimers.
@end enumerate
If the Modified Version includes new front-matter sections or
appendices that qualify as Secondary Sections and contain no material
copied from the Document, you may at your option designate some or all
of these sections as invariant. To do this, add their titles to the
list of Invariant Sections in the Modified Version's license notice.
These titles must be distinct from any other section titles.
You may add a section Entitled ``Endorsements'', provided it contains
nothing but endorsements of your Modified Version by various
parties---for example, statements of peer review or that the text has
been approved by an organization as the authoritative definition of a
standard.
You may add a passage of up to five words as a Front-Cover Text, and a
passage of up to 25 words as a Back-Cover Text, to the end of the list
of Cover Texts in the Modified Version. Only one passage of
Front-Cover Text and one of Back-Cover Text may be added by (or
through arrangements made by) any one entity. If the Document already
includes a cover text for the same cover, previously added by you or
by arrangement made by the same entity you are acting on behalf of,
you may not add another; but you may replace the old one, on explicit
permission from the previous publisher that added the old one.
The author(s) and publisher(s) of the Document do not by this License
give permission to use their names for publicity for or to assert or
imply endorsement of any Modified Version.
@item
COMBINING DOCUMENTS
You may combine the Document with other documents released under this
License, under the terms defined in section 4 above for modified
versions, provided that you include in the combination all of the
Invariant Sections of all of the original documents, unmodified, and
list them all as Invariant Sections of your combined work in its
license notice, and that you preserve all their Warranty Disclaimers.
The combined work need only contain one copy of this License, and
multiple identical Invariant Sections may be replaced with a single
copy. If there are multiple Invariant Sections with the same name but
different contents, make the title of each such section unique by
adding at the end of it, in parentheses, the name of the original
author or publisher of that section if known, or else a unique number.
Make the same adjustment to the section titles in the list of
Invariant Sections in the license notice of the combined work.
In the combination, you must combine any sections Entitled ``History''
in the various original documents, forming one section Entitled
``History''; likewise combine any sections Entitled ``Acknowledgements'',
and any sections Entitled ``Dedications''. You must delete all
sections Entitled ``Endorsements.''
@item
COLLECTIONS OF DOCUMENTS
You may make a collection consisting of the Document and other documents
released under this License, and replace the individual copies of this
License in the various documents with a single copy that is included in
the collection, provided that you follow the rules of this License for
verbatim copying of each of the documents in all other respects.
You may extract a single document from such a collection, and distribute
it individually under this License, provided you insert a copy of this
License into the extracted document, and follow this License in all
other respects regarding verbatim copying of that document.
@item
AGGREGATION WITH INDEPENDENT WORKS
A compilation of the Document or its derivatives with other separate
and independent documents or works, in or on a volume of a storage or
distribution medium, is called an ``aggregate'' if the copyright
resulting from the compilation is not used to limit the legal rights
of the compilation's users beyond what the individual works permit.
When the Document is included in an aggregate, this License does not
apply to the other works in the aggregate which are not themselves
derivative works of the Document.
If the Cover Text requirement of section 3 is applicable to these
copies of the Document, then if the Document is less than one half of
the entire aggregate, the Document's Cover Texts may be placed on
covers that bracket the Document within the aggregate, or the
electronic equivalent of covers if the Document is in electronic form.
Otherwise they must appear on printed covers that bracket the whole
aggregate.
@item
TRANSLATION
Translation is considered a kind of modification, so you may
distribute translations of the Document under the terms of section 4.
Replacing Invariant Sections with translations requires special
permission from their copyright holders, but you may include
translations of some or all Invariant Sections in addition to the
original versions of these Invariant Sections. You may include a
translation of this License, and all the license notices in the
Document, and any Warranty Disclaimers, provided that you also include
the original English version of this License and the original versions
of those notices and disclaimers. In case of a disagreement between
the translation and the original version of this License or a notice
or disclaimer, the original version will prevail.
If a section in the Document is Entitled ``Acknowledgements'',
``Dedications'', or ``History'', the requirement (section 4) to Preserve
its Title (section 1) will typically require changing the actual
title.
@item
TERMINATION
You may not copy, modify, sublicense, or distribute the Document
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense, or distribute it is void, and
will automatically terminate your rights under this License.
However, if you cease all violation of this License, then your license
from a particular copyright holder is reinstated (a) provisionally,
unless and until the copyright holder explicitly and finally
terminates your license, and (b) permanently, if the copyright holder
fails to notify you of the violation by some reasonable means prior to
60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, receipt of a copy of some or all of the same material does
not give you any rights to use it.
@item
FUTURE REVISIONS OF THIS LICENSE
The Free Software Foundation may publish new, revised versions
of the GNU Free Documentation License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns. See
@uref{http://www.gnu.org/copyleft/}.
Each version of the License is given a distinguishing version number.
If the Document specifies that a particular numbered version of this
License ``or any later version'' applies to it, you have the option of
following the terms and conditions either of that specified version or
of any later version that has been published (not as a draft) by the
Free Software Foundation. If the Document does not specify a version
number of this License, you may choose any version ever published (not
as a draft) by the Free Software Foundation. If the Document
specifies that a proxy can decide which future versions of this
License can be used, that proxy's public statement of acceptance of a
version permanently authorizes you to choose that version for the
Document.
@item
RELICENSING
``Massive Multiauthor Collaboration Site'' (or ``MMC Site'') means any
World Wide Web server that publishes copyrightable works and also
provides prominent facilities for anybody to edit those works. A
public wiki that anybody can edit is an example of such a server. A
``Massive Multiauthor Collaboration'' (or ``MMC'') contained in the
site means any set of copyrightable works thus published on the MMC
site.
``CC-BY-SA'' means the Creative Commons Attribution-Share Alike 3.0
license published by Creative Commons Corporation, a not-for-profit
corporation with a principal place of business in San Francisco,
California, as well as future copyleft versions of that license
published by that same organization.
``Incorporate'' means to publish or republish a Document, in whole or
in part, as part of another Document.
An MMC is ``eligible for relicensing'' if it is licensed under this
License, and if all works that were first published under this License
somewhere other than this MMC, and subsequently incorporated in whole
or in part into the MMC, (1) had no cover texts or invariant sections,
and (2) were thus incorporated prior to November 1, 2008.
The operator of an MMC Site may republish an MMC contained in the site
under CC-BY-SA on the same site at any time before August 1, 2009,
provided the MMC is eligible for relicensing.
@end enumerate
@page
@heading ADDENDUM: How to use this License for your documents
To use this License in a document you have written, include a copy of
the License in the document and put the following copyright and
license notices just after the title page:
@smallexample
@group
Copyright (C) @var{year} @var{your name}.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3
or any later version published by the Free Software Foundation;
with no Invariant Sections, no Front-Cover Texts, and no Back-Cover
Texts. A copy of the license is included in the section entitled ``GNU
Free Documentation License''.
@end group
@end smallexample
If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
replace the ``with@dots{}Texts.''@: line with this:
@smallexample
@group
with the Invariant Sections being @var{list their titles}, with
the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
being @var{list}.
@end group
@end smallexample
If you have Invariant Sections without Cover Texts, or some other
combination of the three, merge those two alternatives to suit the
situation.
If your document contains nontrivial examples of program code, we
recommend releasing these examples in parallel under your choice of
free software license, such as the GNU General Public License,
to permit their use in free software.
@c Local Variables:
@c ispell-local-pdict: "ispell-dict"
@c End:

231
examples/gnu-system.scm
View File

@ -1,231 +0,0 @@
;;;; gnu-system.scm - build jobs for Guix
;;;
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; 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/>.
;; Attempt to use Guix modules from git repository.
(eval-when (compile load eval)
;; Ignore any available .go, and force recompilation. This is because our
;; checkout in the store has mtime set to the epoch, and thus .go files look
;; newer, even though they may not correspond.
(set! %fresh-auto-compile #t))
(use-modules (guix config)
(guix store)
(guix grafts)
(guix packages)
(guix derivations)
(guix monads)
((guix licenses)
#:select (gpl3+ license-name license-uri license-comment))
((guix utils) #:select (%current-system))
((guix scripts system) #:select (read-operating-system))
(gnu packages)
(gnu packages commencement)
(gnu packages guile)
(gnu packages make-bootstrap)
(gnu system)
(gnu system vm)
(gnu system install)
(srfi srfi-1)
(ice-9 match))
(define (license->alist lcs)
"Return LCS <license> object as an alist."
;; Sometimes 'license' field is a list of licenses.
(if (list? lcs)
(map license->alist lcs)
`((name . ,(license-name lcs))
(uri . ,(license-uri lcs))
(comment . ,(license-comment lcs)))))
(define (package-metadata package)
"Convert PACKAGE to an alist suitable for Hydra."
`((#:description . ,(package-synopsis package))
(#:long-description . ,(package-description package))
(#:license . ,(license->alist (package-license package)))
(#:home-page . ,(package-home-page package))
(#:maintainers . ("bug-guix@gnu.org"))
(#:max-silent-time . ,(or (assoc-ref (package-properties package)
'max-silent-time)
3600)) ;1 hour by default
(#:timeout . ,(or (assoc-ref (package-properties package) 'timeout)
72000)))) ;20 hours by default
(define (package-job store job-name package system)
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
(λ ()
`((#:job-name . ,(string-append (symbol->string job-name) "." system))
(#:derivation . ,(derivation-file-name
(parameterize ((%graft? #f))
(package-derivation store package system
#:graft? #f))))
,@(package-metadata package))))
(define (package-cross-job store job-name package target system)
"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE
for TARGET on SYSTEM."
(λ ()
`((#:job-name . ,(string-join (list target (symbol->string job-name) system)
"."))
(#:derivation . ,(derivation-file-name
(parameterize ((%graft? #f))
(package-cross-derivation store package target system
#:graft? #f))))
,@(package-metadata package))))
(define %core-packages
;; Note: Don't put the '-final' package variants because (1) that's
;; implicit, and (2) they cannot be cross-built (due to the explicit input
;; chain.)
(append (map specification->package
'("gcc@4.8" "gcc@4.9" "gcc@5" "glibc" "binutils"
"gmp" "mpfr" "mpc" "coreutils" "findutils" "diffutils" "patch" "sed" "grep"
"gawk" "gettext" "hello" "zlib" "gzip" "xz"))
(list guile-2.0
%bootstrap-binaries-tarball
%binutils-bootstrap-tarball
%glibc-bootstrap-tarball
%gcc-bootstrap-tarball
%guile-bootstrap-tarball
%bootstrap-tarballs)))
(define %packages-to-cross-build
%core-packages)
(define %cross-targets
'("mips64el-linux-gnu"
"mips64el-linux-gnuabi64"))
(define (tarball-job store system)
"Return Hydra jobs to build the self-contained Guix binary tarball."
(λ ()
`((#:job-name . (string-append "binary-tarball." system))
(#:derivation . ,(derivation-file-name
(parameterize ((%graft? #f))
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(self-contained-tarball))
#:system system))))
(#:description . "Stand-alone binary Guix tarball")
(#:long-description . "This is a tarball containing binaries of Guix
and all its dependencies, and ready to be installed on non-GuixSD
distributions.")
(#:license . ,(license->alist gpl3+))
(#:home-page . ,%guix-home-page-url)
(#:maintainers . ("bug-guix@gnu.org")))))
(define %job-name
;; Return the name of a package's job.
(compose string->symbol package-full-name))
(define package->job
(let ((base-packages
(delete-duplicates
(append-map (match-lambda
((_ package _ ...)
(match (package-transitive-inputs package)
(((_ inputs _ ...) ...)
inputs))))
%final-inputs))))
(lambda (store package system)
"Return a job for PACKAGE on SYSTEM, or #f if this combination is not
valid."
(cond ((member package base-packages)
#f)
((supported-package? package system)
(package-job store (%job-name package) package system))
(else
#f)))))
;;;
;;; Hydra entry point.
;;;
(define (hydra-jobs store arguments)
"Return Hydra jobs."
(define subset
(match (assoc-ref arguments 'subset)
("core" 'core) ; only build core packages
("hello" 'hello) ; only build hello
(_ 'all))) ; build everything
(define (cross-jobs system)
(define (from-32-to-64? target)
;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
;; mips64el-linux-gnuabi64.
(and (or (string-prefix? "i686-" system)
(string-prefix? "armhf-" system))
(string-suffix? "64" target)))
(define (same? target)
;; Return true if SYSTEM and TARGET are the same thing. This is so we
;; don't try to cross-compile to 'mips64el-linux-gnu' from
;; 'mips64el-linux'.
(string-contains target system))
(define (either proc1 proc2)
(lambda (x)
(or (proc1 x) (proc2 x))))
(append-map (lambda (target)
(map (lambda (package)
(package-cross-job store (%job-name package)
package target system))
%packages-to-cross-build))
(remove (either from-32-to-64? same?) %cross-targets)))
;; Turn off grafts. Grafting is meant to happen on the user's machines.
(parameterize ((%graft? #f))
;; Return one job for each package, except bootstrap packages.
(append-map (lambda (system)
(case subset
((all)
;; Build everything, including replacements.
(let ((pkgs (fold-packages
(lambda (package result)
(if (package-replacement package)
(cons* package
(package-replacement package)
result)
(cons package result)))
'())))
(append (filter-map (lambda (pkg)
(package->job store pkg system))
pkgs)
(list (tarball-job store system))
(cross-jobs system))))
((core)
;; Build core packages only.
(append (map (lambda (package)
(package-job store (%job-name package)
package system))
%core-packages)
(cross-jobs system)))
((hello)
;; Build hello package only.
(if (string=? system (%current-system))
(let ((hello (specification->package "hello")))
(list (package-job store (%job-name hello) hello system)))
'()))
(else
(error "unknown subset" subset))))
%hydra-supported-systems)))

37
examples/guix-jobs.scm
View File

@ -1,37 +0,0 @@
;;; guix-jobs.scm -- job specification test for Guix
;;; 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/>.
(define (local-file file)
;; In the common case jobs will be defined relative to the repository.
;; However for testing purpose use local gnu-system.scm instead.
(string-append (dirname (current-filename)) "/" file))
(define job-base
`((#:name . "guix")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:file . ,(local-file "gnu-system.scm"))
(#:proc . hydra-jobs)))
(define guix-master
(acons #:branch "master" job-base))
(define guix-0.10
(acons #:tag "v0.10.0" job-base))
(list guix-master guix-0.10)

221
examples/guix-track-git.scm
View File

@ -1,221 +0,0 @@
;;; guix-track-git.scm -- job specification tracking a guix packages's git
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Cuirass.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
;;;
;;; This file defines build jobs for the Hydra continuation integration
;;; tool.
;;;
(define local-guix (string-append (getenv "HOME") "/src/guix"))
(define local-cuirass (string-append (getenv "HOME") "/src/cuirass/src"))
;; Attempt to use our very own Guix modules.
(eval-when (compile load eval)
(set! %load-path (cons* local-guix local-cuirass %load-path))
(set! %load-path (cons (string-append local-cuirass "/gnu/packages/patches") %load-path))
(set! %load-compiled-path (cons local-guix %load-compiled-path))
(set! %load-compiled-path (cons local-cuirass %load-compiled-path))
;; Ignore any available .go, and force recompilation. This is because our
;; checkout in the store has mtime set to the epoch, and thus .go files look
;; newer, even though they may not correspond.
(set! %fresh-auto-compile #t))
(use-modules (guix config)
(guix store)
(guix grafts)
(guix packages)
(guix derivations)
(guix monads)
((guix licenses)
#:select (gpl3+ license-name license-uri license-comment))
((guix utils) #:select (%current-system))
((guix scripts system) #:select (read-operating-system))
(gnu packages)
(gnu packages gcc)
(gnu packages base)
(gnu packages gawk)
(gnu packages guile)
(gnu packages gettext)
(gnu packages compression)
(gnu packages multiprecision)
(gnu packages make-bootstrap)
(gnu packages commencement)
(gnu packages package-management)
(gnu system)
(gnu system vm)
(gnu system install)
(gnu tests)
(srfi srfi-1)
(srfi srfi-26)
(ice-9 optargs)
(ice-9 match))
;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
;; port to the bit bucket, let us write to the error port instead.
(setvbuf (current-error-port) _IOLBF)
(set-current-output-port (current-error-port))
(define (license->alist lcs)
"Return LCS <license> object as an alist."
;; Sometimes 'license' field is a list of licenses.
(if (list? lcs)
(map license->alist lcs)
`((name . ,(license-name lcs))
(uri . ,(license-uri lcs))
(comment . ,(license-comment lcs)))))
(define (package-metadata package)
"Convert PACKAGE to an alist suitable for Hydra."
`((#:description . ,(package-synopsis package))
(#:long-description . ,(package-description package))
(#:license . ,(license->alist (package-license package)))
(#:home-page . ,(package-home-page package))
(#:maintainers . ("bug-guix@gnu.org"))
(#:max-silent-time . ,(or (assoc-ref (package-properties package)
'max-silent-time)
3600)) ;1 hour by default
(#:timeout . ,(or (assoc-ref (package-properties package) 'timeout)
72000)))) ;20 hours by default
(define (package-job store job-name package system)
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
(λ ()
`((#:job-name . ,(string-append (symbol->string job-name) "." system))
(#:derivation . ,(derivation-file-name
(parameterize ((%graft? #f))
(package-derivation store package system
#:graft? #f))))
,@(package-metadata package))))
(define job-name
;; Return the name of a package's job.
(compose string->symbol package-full-name))
(define package->job
(let ((base-packages
(delete-duplicates
(append-map (match-lambda
((_ package _ ...)
(match (package-transitive-inputs package)
(((_ inputs _ ...) ...)
inputs))))
%final-inputs))))
(lambda (store package system)
"Return a job for PACKAGE on SYSTEM, or #f if this combination is not
valid."
(cond ((member package base-packages)
#f)
((supported-package? package system)
(package-job store (job-name package) package system))
(else
#f)))))
;;; END hydra/gnu-system.scm
;;;
;;; Cuirass CI tracking packages' git
;;;
(use-modules (srfi srfi-11)
(srfi srfi-9 gnu)
(rnrs io ports)
(gnu packages)
(guix base32)
(guix git-download)
(guix hash)
(guix packages)
(guix serialization)
(guix utils)
(guix ui)
(cuirass base))
(define (url->file-name url)
(string-trim
(string-map (lambda (c) (if (memq c (string->list ":/")) #\- c)) url)
#\-))
(define* (package->spec pkg #:key (branch "master") commit url)
(let ((url (or url ((compose git-reference-url origin-uri package-source) pkg))))
`((#:name . ,(url->file-name url))
(#:url . ,url)
(#:branch . ,branch)
(#:commit . ,commit))))
(define (vcs-file? file stat)
(case (stat:type stat)
((directory)
(member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
(else
#f)))
(define select? (negate vcs-file?))
(define (file-hash file)
;; Compute the hash of FILE.
;; Catch and gracefully report possible '&nar-error' conditions.
(with-error-handling
(let-values (((port get-hash) (open-sha256-port)))
(write-file file port #:select? select?)
(flush-output-port port)
(get-hash))))
(define (commit? string)
(string-every (string->char-set "0123456789abcdef") string))
(define (call-with-output-fdes fdes new-file thunk)
(let ((outport (fdes->outport fdes))
(port (open-file new-file "w")))
(move->fdes port fdes)
(let ((result (thunk)))
(move->fdes port fdes)
result)))
(define* (package->git-tracked pkg #:key (branch "master") commit url)
(let* ((source (package-source pkg))
(uri (origin-uri source)))
(if (not branch) pkg
(let* ((spec (package->spec pkg #:branch branch #:commit commit #:url url))
(commit (call-with-output-fdes 1 "/dev/null"
(lambda () (fetch-repository spec))))
(url (or url (git-reference-url uri)))
(git-dir (string-append (%package-cachedir) "/" (url->file-name url)))
(hash (bytevector->nix-base32-string (file-hash git-dir)))
(source (origin (uri (git-reference (url url) (commit commit)))
(method git-fetch)
(sha256 (base32 hash)))))
(set-fields pkg ((package-source) source))))))
;;;
;;; Guix entry point.
;;;
(define (guix-jobs store arguments)
(let* ((name (or (assoc-ref arguments 'name) "hello"))
(pkg (specification->package name))
(branch (or (assoc-ref arguments 'branch) "master"))
(url (assoc-ref arguments 'url))
(pkg.git (package->git-tracked pkg #:branch branch #:url url))
(system (or (assoc-ref arguments 'system) "x86_64-linux")))
(parameterize ((%graft? #f))
(list (package-job store (job-name pkg) pkg.git system)))))

53
examples/hello-git.scm
View File

@ -1,53 +0,0 @@
;;; hello-git.scm -- job specification test for hello git repository
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@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 (srfi srfi-1))
(define (local-file file)
;; In the common case jobs will be defined relative to the repository.
;; However for testing purpose use local gnu-system.scm instead.
(string-append (dirname (current-filename)) "/" file))
(define (url->file-name url)
(string-trim
(string-map (lambda (c) (if (memq c (string->list ":/")) #\- c)) url)
#\-))
(define vc
;; where your version-control checkouts live
(string-append (getenv "HOME") "/src"))
(define guix-checkout (string-append vc "/guix"))
;; building GNU hello from git is too much work
;; (define hello-checkout (string-append vc "/hello"))
;; (define hello-git "http://git.savannah.gnu.org/r/hello.git")
;; ... so let's track cuirass' git
(define cuirass-checkout (string-append vc "/cuirass"))
(define cuirass-git "https://notabug.org/mthl/cuirass")
;;(define cuirass-git "https://gitlab.com/janneke/cuirass.git")
(list
`((#:name . ,(url->file-name cuirass-checkout))
(#:url . ,cuirass-git)
(#:branch . "master")
(#:no-compile? . #t)
(#:load-path . ,guix-checkout)
(#:proc . guix-jobs)
(#:file . ,(local-file "guix-track-git.scm"))
(#:arguments (name . "cuirass") (url . ,cuirass-git))))

33
examples/hello-singleton.scm
View File

@ -1,33 +0,0 @@
;;; hello-singleton.scm -- job specification test for hello in master
;;; 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/>.
(define (local-file file)
;; In the common case jobs will be defined relative to the repository.
;; However for testing purpose use local gnu-system.scm instead.
(string-append (dirname (current-filename)) "/" file))
(define hello-master
`((#:name . "guix")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:file . ,(local-file "gnu-system.scm"))
(#:proc . hydra-jobs)
(#:arguments (subset . "hello"))
(#:branch . "master")))
(list hello-master)

43
examples/hello-subset.scm
View File

@ -1,43 +0,0 @@
;;; hello-subset.scm -- job specification test for hello subset
;;; 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/>.
(define (local-file file)
;; In the common case jobs will be defined relative to the repository.
;; However for testing purpose use local gnu-system.scm instead.
(string-append (dirname (current-filename)) "/" file))
(define job-base
`((#:name . "guix")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:file . ,(local-file "gnu-system.scm"))
(#:proc . hydra-jobs)
(#:arguments (subset . "hello"))))
(define guix-master
(acons #:branch "master" job-base))
(define guix-core-updates
(acons #:branch "core-updates" job-base))
(define guix-0.10
(acons #:tag "v0.10.0" job-base))
(list guix-master
guix-core-updates
guix-0.10)

34
src/cuirass.scm
View File

@ -1,34 +0,0 @@
;;;; cuirass.scm -- Cuirass public interface.
;;; 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/>.
;;;; Commentary:
;;;
;;; This composite module re-exports everything from the public submodules.
;;;
;;;; Code:
(define-module (cuirass))
;;; Module usages and exports need to be done at expansion time.
(eval-when (eval load expand)
(let ((i (module-public-interface (current-module))))
(for-each (λ (m) (module-use! i (resolve-interface m)))
;; Public modules.
'((cuirass base)
(cuirass database)
(cuirass http)))))

219
src/cuirass/base.scm
View File

@ -1,17 +1,16 @@
;;; base.scm -- Cuirass base module
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;; base.scm - Cuirass base module
;;;
;;; Copyright © 2012, 2016 Ludovic Courtès <ludo@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 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
;;; 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.
;;;
@ -19,44 +18,30 @@
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(define-module (cuirass base)
#:use-module (cuirass database)
#:use-module (cuirass utils)
#:use-module (gnu packages)
#:use-module (guix derivations)
#:use-module (guix store)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-34)
#:export (;; Procedures.
call-with-time-display
fetch-repository
compile
evaluate
build-packages
process-specs
set-guix-package-path!
;; Parameters.
%guix-package-path
%package-cachedir
%use-substitutes?))
#:export (guix-variable
with-directory-excursion
call-with-time-display))
(define %use-substitutes?
;; Define whether to use substitutes
(make-parameter #f))
(define (guix-variable module name)
"Dynamically link variable NAME under Guix module MODULE and return it.
Note: this is used instead of `@', because when using `@' in an uncompiled
file, Guile tries to load the module directly as it reads the source, which
fails in our case, leading to the creation of empty (guix ...) modules."
(let ((m (resolve-interface `(guix ,module))))
(module-ref m name)))
(define %package-cachedir
;; Define to location of cache directory of this package.
(make-parameter (or (getenv "CUIRASS_CACHEDIR")
(string-append (or (getenv "HOME") ".")
"/.cache/cuirass"))
(λ (val)
(if (string? val)
val
(scm-error 'wrong-type-arg
"%package-cachedir" "Not a string: ~S" (list #f) #f)))))
(define-syntax-rule (with-directory-excursion dir body ...)
"Run BODY with DIR as the process's current directory."
(let ((init (getcwd)))
(dynamic-wind
(lambda ()
(chdir dir))
(lambda ()
body ...)
(lambda ()
(chdir init)))))
(define (call-with-time thunk kont)
"Call THUNK and pass KONT the elapsed time followed by THUNK's return
@ -69,144 +54,8 @@ values."
(define (call-with-time-display thunk)
"Call THUNK and write to the current output port its duration."
(call-with-time thunk
(λ (time result)
(let ((duration (+ (time-second time)
(/ (time-nanosecond time) 1e9))))
(format (current-error-port) "evaluate '~A': ~,3f seconds~%"
(assq-ref result #:job-name)
duration)
(acons #:duration duration result)))))
(define (fetch-repository spec)
"Get the latest version of repository specified in SPEC. Clone repository
if required. Return the last commit ID on success, #f otherwise."
(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)))
(mkdir-p 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)))
(and (or (file-exists? name)
(zero? (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))
(%guix-package-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."
(define (register job)
(let* ((name (assq-ref job #:job-name))
(drv (assq-ref job #:derivation))
(eval-id (assq-ref job #:eval-id))
;; XXX: How to keep logs from several attempts?
(log (log-file store drv))
(outputs (match (derivation-path->output-paths drv)
(((names . items) ...)
(filter (λ (item)
(valid-path? store item))
items)))))
(for-each (λ (output)
(let ((build `((#:derivation . ,drv)
(#:eval-id . ,eval-id)
(#:log . ,log)
(#:output . ,output))))
(db-add-build db build)))
outputs)
(format #t "~{~A ~}\n" outputs)
build))
;; Pass all the jobs at once so we benefit from as much parallelism as
;; possible (we must be using #:keep-going? #t). Swallow build errors.
(guard (c ((nix-protocol-error? c) #t))
(format #t "building ~a derivations...~%" (length jobs))
(build-derivations store (map (λ (job)
(assq-ref job #:derivation))
jobs)))
;; Register the results in the database.
;; XXX: The 'build-derivations' call is blocking so we end updating the
;; database potentially long after things have been built.
(map register jobs))
(define (process-specs db jobspecs)
"Evaluate and build JOBSPECS and store results in DB."
(define (process spec)
(let ((commit (fetch-repository spec))
(stamp (db-get-stamp db spec)))
(when commit
(unless (string=? commit stamp)
(unless (assq-ref spec #:no-compile?)
(compile (string-append (%package-cachedir) "/"
(assq-ref spec #:name))))
(with-store store
;; Always set #:keep-going? so we don't stop on the first build
;; failure.
(set-build-options store
#:use-substitutes? (%use-substitutes?)
#:keep-going? #t)
(let* ((spec* (acons #:current-commit commit spec))
(jobs (evaluate store db spec*)))
(build-packages store db jobs))))
(db-add-stamp db spec commit))))
(for-each process jobspecs))
;;;
;;; Guix package path.
;;;
(define %guix-package-path
;; Extension of package modules search path.
(make-parameter ""))
(define (set-guix-package-path! path)
"Use PATH to find custom packages not defined in (gnu packages ...)
namespace or not already present in current Guile load paths. PATH is
expected to be a colon-separated string of directories."
(define (set-paths! dir)
(%package-module-path (cons dir (%package-module-path)))
(%patch-path (cons dir (%patch-path)))
(set! %load-path (cons dir %load-path))
(set! %load-compiled-path (cons dir %load-compiled-path)))
(let ((dirs (parse-path path)))
(for-each set-paths! dirs)))
(lambda (time . results)
(format #t "~,3f seconds~%"
(+ (time-second time)
(/ (time-nanosecond time) 1e9)))
(apply values results))))

58
src/cuirass/config.scm.in
View File

@ -1,58 +0,0 @@
;;;; config.scm -- constants defined by the build system.
;;; @configure_input@
;;; 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/>.
(define-module (cuirass config))
(define-public %package
;; Name of package
"@PACKAGE@")
(define-public %package-bugreport
;; Define to the address where bug reports for this package should be sent.
"@PACKAGE_BUGREPORT@")
(define-public %package-name
;; Define to the full name of this package.
"@PACKAGE_NAME@")
(define-public %package-string
;; Define to the full name and version of this package.
"@PACKAGE_STRING@")
(define-public %package-tarname
;; Define to the one symbol short name of this package.
"@PACKAGE_TARNAME@")
(define-public %package-url
;; Define to the home page for this package.
"@PACKAGE_URL@")
(define-public %package-version
;; Define to the version of this package.
"@PACKAGE_VERSION@")
(define-public %datadir
;; Define to 'PREFIX/share' which is a read-only architecture-independent
;; data directory.
"@datadir@")
(define-public %localstatedir
;; Define to 'PREFIX/var' which is a modifiable single-machine data
;; directory.
"@localstatedir@")

213
src/cuirass/database.scm
View File

@ -1,213 +0,0 @@
;;; database.scm -- store evaluation and build results
;;; Copyright © 2016, 2017 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/>.
(define-module (cuirass database)
#:use-module (cuirass config)
#:use-module (cuirass utils)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (sqlite3)
#:export (;; Procedures.
assq-refs
db-init
db-open
db-close
db-add-specification
db-get-specifications
db-add-stamp
db-get-stamp
db-add-evaluation
db-add-derivation
db-get-derivation
db-add-build
read-sql-file
read-quoted-string
sqlite-exec
;; Parameters.
%package-database
%package-schema-file
;; Macros.
with-database))
(define (sqlite-exec db msg . args)
"Wrap 'sqlite-prepare', 'sqlite-step', and 'sqlite-finalize'. Send message
MSG to database DB. MSG can contain '~A' and '~S' escape characters which
will be replaced by ARGS."
(let* ((sql (apply simple-format #f msg args))
(stmt (sqlite-prepare db sql))
(res (let loop ((res '()))
(let ((row (sqlite-step stmt)))
(if (not row)
(reverse! res)
(loop (cons row res)))))))
(sqlite-finalize stmt)
res))
(define %package-database
;; Define to the database file name of this package.
(make-parameter (string-append %localstatedir "/" %package ".db")))
(define %package-schema-file
;; Define to the database schema file of this package.
(make-parameter (string-append (or (getenv "CUIRASS_DATADIR")
(string-append %datadir "/" %package))
"/schema.sql")))
(define (read-sql-file file-name)
"Return a list of string containing SQL instructions from FILE-NAME."
(call-with-input-file file-name
(λ (port)
(let loop ((insts '()))
(let ((inst (read-delimited ";" port 'concat)))
(if (or (eof-object? inst)
;; Don't cons the spaces after the last instructions.
(string-every char-whitespace? inst))
(reverse! insts)
(loop (cons inst insts))))))))
(define* (db-init #:optional (db-name (%package-database))
#:key (schema (%package-schema-file)))
"Open the database to store and read jobs and builds informations. Return a
database object."
(when (file-exists? db-name)
(format (current-error-port) "Removing leftover database ~a~%" db-name)
(delete-file db-name))
(let ((db (sqlite-open db-name (logior SQLITE_OPEN_CREATE
SQLITE_OPEN_READWRITE))))
(for-each (λ (sql) (sqlite-exec db sql))
(read-sql-file schema))
db))
(define* (db-open #:optional (db (%package-database)))
"Open database to store or read jobs and builds informations. Return a
database object."
(if (file-exists? db)
(sqlite-open db SQLITE_OPEN_READWRITE)
(db-init db)))
(define (db-close db)
"Close database object DB."
(sqlite-close db))
(define* (assq-refs alst keys #:optional default-value)
(map (λ (key) (or (assq-ref alst key) default-value))
keys))
(define (last-insert-rowid db)
(vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
0))
(define (db-add-specification db spec)
"Store specification SPEC in database DB and return its ID."
(apply sqlite-exec db "\
INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \
proc, arguments, branch, tag, revision, no_compile_p) \
VALUES ('~A', '~A', '~A', '~A', '~S', '~S', '~A', '~A', '~A', ~A);"
(append
(assq-refs spec '(#:name #:url #:load-path #:file #:proc #:arguments))
(assq-refs spec '(#:branch #:tag #:commit) "NULL")
(list (if (assq-ref spec #:no-compile?) "1" "0"))))
(last-insert-rowid db))
(define (db-get-specifications db)
(let loop ((rows (sqlite-exec db "SELECT * FROM Specifications;"))
(specs '()))
(match rows
(() specs)
((#(name url load-path file proc args branch tag rev no-compile?)
. rest)
(loop rest
(cons `((#:name . ,name)
(#:url . ,url)
(#:load-path . ,load-path)
(#:file . ,file)
(#:proc . ,(with-input-from-string proc read))
(#:arguments . ,(with-input-from-string args read))
(#:branch . ,branch)
(#:tag . ,(if (string=? tag "NULL") #f tag))
(#:commit . ,(if (string=? rev "NULL") #f rev))
(#:no-compile? . ,(positive? no-compile?)))
specs))))))
(define (db-add-derivation db job)
"Store a derivation result in database DB and return its ID."
(sqlite-exec db "\
INSERT OR IGNORE INTO Derivations (derivation, job_name, evaluation)\
VALUES ('~A', '~A', '~A');"
(assq-ref job #:derivation)
(assq-ref job #:job-name)
(assq-ref job #:eval-id)))
(define (db-get-derivation db id)
"Retrieve a job in database DB which corresponds to ID."
(car (sqlite-exec db "SELECT * FROM Derivations WHERE derivation='~A';" id)))
(define (db-add-evaluation db eval)
(sqlite-exec db "\
INSERT INTO Evaluations (specification, revision) VALUES ('~A', '~A');"
(assq-ref eval #:specification)
(assq-ref eval #:revision))
(last-insert-rowid db))
(define-syntax-rule (with-database db body ...)
"Run BODY with a connection to the database which is bound to DB in BODY."
(let ((db (db-open)))
(dynamic-wind
(const #t)
(λ () body ...)
(λ () (db-close db)))))
(define* (read-quoted-string #:optional (port (current-input-port)))
"Read all of the characters out of PORT and return them as a SQL quoted
string."
(let loop ((chars '()))
(let ((char (read-char port)))
(cond ((eof-object? char) (list->string (reverse! chars)))
((char=? char #\') (loop (cons* char char chars)))
(else (loop (cons char chars)))))))
(define (db-add-build db build)
"Store BUILD in database DB."
(sqlite-exec db "\
INSERT INTO Builds (derivation, evaluation, log, output)\
VALUES ('~A', '~A', '~A', '~A');"
(assq-ref build #:derivation)
(assq-ref build #:eval-id)
(assq-ref build #:log)
(assq-ref build #:output))
(last-insert-rowid db))
(define (db-get-stamp db spec)
"Return a stamp corresponding to specification SPEC in database DB."
(let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification='~A';"
(assq-ref spec #:id))))
(match res
(() "")
((#(spec commit)) commit))))
(define (db-add-stamp db spec commit)
"Associate stamp COMMIT to specification SPEC in database DB."
(if (string-null? (db-get-stamp db spec))
(sqlite-exec db "\
INSERT INTO Stamps (specification, stamp) VALUES ('~A', '~A');"
(assq-ref spec #:id)
commit)
(sqlite-exec db "\
UPDATE Stamps SET stamp='~A' WHERE specification='~A';"
commit
(assq-ref spec #:id))))

78
src/cuirass/http.scm
View File

@ -1,78 +0,0 @@
;;;; http.scm -- HTTP API
;;; 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/>.
(define-module (cuirass http)
#:use-module (cuirass database)
#:use-module (cuirass utils)
#:use-module (ice-9 hash-table)
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (web request)
#:use-module (web response)
#:use-module (web server)
#:use-module (web uri)
#:export (spec->json-string
run-cuirass-server))
;;;
;;; JSON format.
;;;
(define (object->json-scm obj)
"Prepare OBJ for JSON usage."
(cond ((string? obj) obj)
((number? obj) obj)
((boolean? obj) obj)
((null? obj) obj)
((symbol? obj) (symbol->string obj))
((keyword? obj) (object->json-scm (keyword->symbol obj)))
((alist? obj) (alist->hash-table (map object->json-scm obj)))
((pair? obj) (cons (object->json-scm (car obj))
(object->json-scm (cdr obj))))
(else (object->string obj))))
(define* (spec->json-string spec #:key pretty)
"Return SPEC as a JSON object."
(scm->json-string (object->json-scm spec) #:pretty pretty))
;;;
;;; Web server.
;;;
(define (request-path-components request)
(split-and-decode-uri-path (uri-path (request-uri request))))
(define (url-handler request body db)
(define* (respond response #:key body (db db))
(values response body db))
(match (request-path-components request)
(((or "jobsets" "specifications") . rest)
(respond '((content-type . (application/json)))
#:body (spec->json-string (car (db-get-specifications db)))))
(_
(respond (build-response #:code 404)
#:body (string-append "Resource not found: "
(uri->string (request-uri request)))))))
(define* (run-cuirass-server db #:key (port 8080))
(format (current-error-port) "listening on port ~A~%" port)
(run-server url-handler
'http ;server implementation
`(#:port ,port) ;implementation parameters
db)) ;state

116
src/cuirass/repo.scm
View File

@ -1,116 +0,0 @@
;;;; repo.scm -- manage code repositories
;;; 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/>.
(define-module (cuirass repo)
#:use-module (cuirass utils)
#:use-module (guix store)
#:use-module (srfi srfi-9 gnu)
#:export (repo
repo?
repo-id
repo-url
repo-location
repo-reference
repo-snapshoter
repo-snapshot
repo-updater
repo-update
file-repo
git-repo))
(define-immutable-record-type <repo>
;; An Abstract repository. Use "repo" as a shortname for "repository".
(make-repo id url location ref snapshoter updater)
repo?
(id repo-id) ;string
(url repo-url) ;string
(location repo-location) ;string
(ref repo-reference) ;string
(snapshoter repo-snapshoter) ;method
(updater repo-updater)) ;method
(define* (repo #:key id url location ref snapshoter updater)
;; Convenient <repo> constructor using keyword arguments.
(make-repo id url location ref snapshoter updater))
(define (repo-snapshot repo store)
"Send a snapshot of REPO to the STORE."
((repo-snapshoter repo) repo store))
(define* (repo-update repo #:optional ref)
"Pull changes from REPO according to reference REF."
((repo-updater repo) repo ref))
;;;
;;; Concrete repositories.
;;;
(define file-repo
(let ((hash-algo "sha256"))
(define (file-repo-snapshot this store)
;; Send file to the STORE.
(let* ((basename (repo-id this))
(file (repo-location this))
(directory? (eq? 'directory (stat:type (stat file)))))
(add-to-store store basename directory? hash-algo file)))
(define (file-repo-update this ref)
;; Ensure that file still exists.
(stat (repo-location this)))
(λ* (file-name #:key id)
"Basic repository that handles a local file or directory."
(repo #:id (or id file-name)
#:location file-name
#:snapshoter file-repo-snapshot
#:updater file-repo-update))))
(define git-repo
(let ((git "git")
(hash-algo "sha256"))
(define (git-repo-snapshot this store)
"Add a snapshot of URL to STORE. "
(let ((dir (repo-location this))
(id (repo-id this)))
(call-with-temporary-directory
(λ (tmpdir)
(let ((tmp-repo (string-append tmpdir "/" dir)))
(and (zero? (system* "cp" "-R" dir tmpdir))
(with-directory-excursion tmp-repo
(zero? (system* "rm" "-rf" ".git")))
(add-to-store store id #t hash-algo tmp-repo)))))))
(define (git-repo-update this ref)
(let ((url (repo-url this))
(dir (repo-location this)))
(and
(or (file-exists? dir)
(zero? (system* git "clone" url dir))
(error "file not found"))
(with-directory-excursion dir
(and (zero? (system* git "pull"))
(zero? (system* git "reset" "--hard" ref)))))))
(λ* (#:key url dir)
"Create a Git repository. URL is the location of the remote repository.
REF is the identifier that is tracked."
(repo #:id dir
#:url url
#:location dir
#:snapshoter git-repo-snapshot
#:updater git-repo-update))))

52
src/cuirass/ui.scm
View File

@ -1,52 +0,0 @@
;;; ui.scm -- user interface facilities for command-line tools
;;; Copyright © 2016, 2017 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/>.
(define-module (cuirass ui)
#:use-module (cuirass config)
#:export (;; Procedures.
show-version
show-package-information
;; Parameters.
%program-name))
(define %program-name
;; Similar in spirit to Gnulib 'progname' module.
(make-parameter ""
(λ (val)
(cond ((not (string? val))
(scm-error 'wrong-type-arg
"%program-name" "Not a string: ~S" (list #f) #f))
((string-rindex val #\/) => (λ (idx) (substring val (1+ idx))))
(else val)))))
(define (show-version)
"Display version information for COMMAND."
(simple-format #t "~a (~a) ~a~%"
(%program-name) %package-name %package-version)
(display "Copyright (C) 2016 the Cuirass authors
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.")
(newline))
(define (show-package-information)
(newline)
(format #t "Report bugs to: ~a." %package-bugreport)
(newline)
(format #t "~A home page: <~A>" %package-name %package-url)
(newline))

102
src/cuirass/utils.scm
View File

@ -1,102 +0,0 @@
;;; utils.scm -- helper procedures
;;; Copyright © 2012, 2013, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; 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/>.
(define-module (cuirass utils)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (;; Procedures
alist?
mkdir-p
make-user-module
call-with-temporary-directory
;; Macros.
λ*
with-directory-excursion))
(define-syntax-rule (λ* formals body ...)
(lambda* formals body ...))
(define (alist? obj)
"Return #t if OBJ is an alist."
(and (list? obj)
(every pair? obj)))
(define mkdir-p
(let ((not-slash (char-set-complement (char-set #\/))))
(λ* (dir #:optional mode)
"Create directory DIR and all its ancestors."
(let ((absolute? (string-prefix? "/" dir)))
(let loop ((components (string-tokenize dir not-slash))
(root (if absolute? "" ".")))
(match components
((head tail ...)
(let ((dir-name (string-append root "/" head)))
(catch 'system-error
(λ ()
(if mode
(mkdir dir-name mode)
(mkdir dir-name))
(loop tail dir-name))
(λ args
;; On GNU/Hurd we can get EROFS instead of EEXIST here.
;; Thus, if we get something other than EEXIST, check
;; whether DIR-NAME exists. See
;; <https://lists.gnu.org/archive/html/guix-devel/2016-02/msg00049.html>.
(if (or (= EEXIST (system-error-errno args))
(let ((st (stat dir-name #f)))
(and st (eq? 'directory (stat:type st)))))
(loop tail dir-name)
(apply throw args))))))
(() #t)))))))
(define-syntax-rule (with-directory-excursion dir body ...)
"Run BODY with DIR as the process's current directory."
(let ((init (getcwd)))
(dynamic-wind
(λ () (chdir dir))
(λ () body ...)
(λ () (chdir init)))))
(define* (make-user-module #:optional (modules '()))
"Return a new user module with the additional MODULES loaded."
;; Module in which the machine description file is loaded.
(let ((module (make-fresh-user-module)))
(for-each (lambda (iface)
(module-use! module (resolve-interface iface)))
modules)
module))
;;;
;;; Temporary files.
;;;
(define (call-with-temporary-directory proc)
"Call PROC with a name of a temporary directory; close the directory and
delete it when leaving the dynamic extent of this call."
(let* ((parent (or (getenv "TMPDIR") "/tmp"))
(tmp-dir (string-append parent "/" (basename (tmpnam)))))
(mkdir-p tmp-dir)
(dynamic-wind
(const #t)
(lambda ()
(proc tmp-dir))
(lambda ()
(false-if-exception (rmdir tmp-dir))))))

50
src/schema.sql
View File

@ -1,50 +0,0 @@
BEGIN TRANSACTION;
CREATE TABLE Specifications (
repo_name TEXT NOT NULL PRIMARY KEY,
url TEXT NOT NULL,
load_path TEXT NOT NULL,
file TEXT NOT NULL,
proc TEXT NOT NULL,
arguments TEXT NOT NULL,
-- The following columns are optional.
branch TEXT,
tag TEXT,
revision TEXT,
no_compile_p INTEGER
);
CREATE TABLE Stamps (
specification TEXT NOT NULL PRIMARY KEY,
stamp TEXT NOT NULL,
FOREIGN KEY (specification) REFERENCES Specifications (repo_name)
);
CREATE TABLE Evaluations (
id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
specification TEXT NOT NULL,
revision TEXT NOT NULL,
FOREIGN KEY (specification) REFERENCES Specifications (repo_name)
);
CREATE TABLE Derivations (
derivation TEXT NOT NULL,
evaluation INTEGER NOT NULL,
job_name TEXT NOT NULL,
PRIMARY KEY (derivation, evaluation),
FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
);
-- Builds are not in a one to one relationship with derivations in order to
-- keep track of non deterministic compilations.
CREATE TABLE Builds (
derivation TEXT NOT NULL,
evaluation INTEGER NOT NULL,
log TEXT NOT NULL,
output TEXT, -- NULL if build failed
PRIMARY KEY (derivation, evaluation, output),
FOREIGN KEY (derivation) REFERENCES Derivations (derivation),
FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
);
COMMIT;

23
tests/base.scm
View File

@ -1,15 +1,16 @@
;;; base.scm -- tests for (cuirass base) module
;;;; base.scm - tests for (cuirass base) module
;;;
;;; 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 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
;;; 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.
;;;
@ -18,11 +19,3 @@
(use-modules (cuirass base)
(srfi srfi-64))
(test-begin "base")
(test-error "invalid cache directory"
'wrong-type-arg
(%package-cachedir #f))
(test-end)

24
tests/basic.sh
View File

@ -1,24 +0,0 @@
# basic.sh -- check cuirass basic behavior
# 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/>.
db_file=${testbuilddir}/test.db
spec_file=${testsrcdir}/hello-subset.scm
trap 'rm -f "$db_file"' EXIT
cuirass --database $db_file --one-shot $spec_file

84
tests/database.scm
View File

@ -1,84 +0,0 @@
;;;; database.scm - tests for (cuirass database) module
;;;
;;; 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 database)
(srfi srfi-64))
(define example-spec
'((#:name . "guix")
(#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:file . "/tmp/gnu-system.scm")
(#:proc . hydra-jobs)
(#:arguments (subset . "hello"))
(#:branch . "master")
(#:tag . #f)
(#:commit . #f)
(#:no-compile? . #f)))
(define* (make-dummy-job #:optional (name "foo"))
`((#:name . ,name)
(#:derivation . ,(string-append name ".drv"))
(#:specification 0)))
(define %db
;; Global Slot for a database object.
(make-parameter #t))
(define %id
;; Global Slot for a job ID in the database.
(make-parameter #t))
(define database-name
;; Use an empty and temporary database for the tests.
(string-append (getcwd) "/" (number->string (getpid)) "-tmp.db"))
(test-group-with-cleanup "database"
(test-assert "db-init"
(%db (db-init database-name)))
(test-assert "sqlite-exec"
(begin
(sqlite-exec (%db) "\
INSERT INTO Evaluations (specification, revision) VALUES (1, 1);")
(sqlite-exec (%db) "\
INSERT INTO Evaluations (specification, revision) VALUES (2, 2);")
(sqlite-exec (%db) "\
INSERT INTO Evaluations (specification, revision) VALUES (3, 3);")
(sqlite-exec (%db) "SELECT * FROM Evaluations;")))
(test-equal "db-add-specification"
example-spec
(begin
(db-add-specification (%db) example-spec)
(car (db-get-specifications (%db)))))
(test-assert "db-add-derivation"
(let* ((job (make-dummy-job))
(key (assq-ref job #:derivation)))
(db-add-derivation (%db) job)
(%id key)))
(test-assert "db-get-derivation"
(db-get-derivation (%db) (%id)))
(test-assert "db-close"
(db-close (%db)))
(delete-file database-name))

40
tests/http.scm
View File

@ -1,40 +0,0 @@
;;; http.scm -- tests for (cuirass http) module
;;; 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 http)
(srfi srfi-64))
(test-begin "http")
(test-equal "spec->json-string"
(string-append "{"
"\"boolean\" : false,"
"\"string\" : \"guix\","
"\"alist\" : {\"subset\" : \"hello\"},"
"\"list\" : [1, \"2\", \"three\"],"
"\"symbol\" : \"hydra-jobs\","
"\"number\" : 1"
"}")
(spec->json-string '((#:number . 1)
(string . "guix")
("symbol" . hydra-jobs)
(#:alist (subset . "hello"))
(list 1 "2" #:three)
("boolean" . #f))))
(test-end)

113
tests/repo.scm
View File

@ -1,113 +0,0 @@
;;;; repo.scm -- tests for (cuirass repo) module
;;; 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 repo)
(cuirass utils)
(guix store)
(srfi srfi-64))
(test-begin "repo")
(test-equal "<repo> datatype"
;; Check that all the procedures for manipulating <repo> objects are
;; exported and that the keywords of the constructor matches their slot.
'(1 2 3 4 5 6)
(let ((obj (repo #:id 1 #:url 2 #:location 3 #:ref 4
#:snapshoter 5 #:updater 6)))
(and (repo? obj)
(list (repo-id obj)
(repo-url obj)
(repo-location obj)
(repo-reference obj)
(repo-snapshoter obj)
(repo-updater obj)))))
(define file-name
(pk (simple-format #f "tmp-~S" (getpid))))
(define store
(open-connection))
(define (create-file name)
"Create a dummy file in current directory."
(with-output-to-file name
(λ () (display "test!\n"))))
(define (in-store? file-name)
"Check if FILE-NAME is in the store. FILE-NAME must be an absolute file
name."
(string-prefix? "/gnu/store" file-name))
;;;
;;; File repository.
;;;
(test-group-with-cleanup "file-repo"
(define rpt (pk (file-repo file-name)))
;; Since file doesn't exist yet, 'repo-update' should throw an error.
(test-error "file-repo-update: file not found"
'system-error
(repo-update rpt))
(create-file file-name)
(test-assert "file-repo-update"
(repo-update rpt))
(test-assert "file-repo-snapshot"
(in-store? (repo-snapshot rpt store)))
;; Cleanup.
(delete-file file-name))
;;;
;;; Git repository.
;;;
(define (create-git-repository name)
(let ((git "git"))
(system* git "init" name)
(with-directory-excursion name
(create-file "foo")
(system* git "add" "foo")
(system* git "commit" "-m" "'foo'"))))
(test-group-with-cleanup "git-repo"
(define rpt (git-repo #:url file-name
#:dir "git-example"))
;; Since repository doesn't exist yet, 'repo-update' should throw an error.
(test-error "git-repo-update: file not found"
'system-error
(repo-update rpt "master"))
(create-git-repository file-name)
(test-assert "git-repo-update"
(repo-update rpt "master"))
(test-assert "git-repo-snapshot"
(in-store? (repo-snapshot rpt store)))
;; Cleanup.
(system* "rm" "-rf" file-name "git-example"))
(close-connection store)
(test-end)

28
tests/ui.scm
View File

@ -1,28 +0,0 @@
;;; ui.scm -- tests for (cuirass ui) module
;;; 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 ui)
(srfi srfi-64))
(test-begin "ui")
(test-error "invalid program name"
'wrong-type-arg
(%program-name #f))
(test-end)

53
tests/utils.scm
View File

@ -1,53 +0,0 @@
;;;; utils.scm -- tests for (cuirass utils) module
;;;
;;; 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 utils)
(srfi srfi-64))
(define dir-1 (make-parameter ""))
(define dir-2 (make-parameter ""))
(test-begin "utils")
(test-assert "alist?"
(and (alist? '())
(alist? '(("foo" 1 2)))
(alist? '(("foo" . 1)
("bar" . 2)))
(not (alist? 3))
(not (alist? '(1 2 3)))
(not (alist? 'foo))
(not (alist? #:bar))))
(test-assert "with-directory-excursion"
(let ((old (getcwd))
(tmp (tmpnam)))
(dynamic-wind
(λ ()
(mkdir tmp))
(λ ()
(with-directory-excursion tmp
(dir-1 (getcwd)))
(dir-2 (getcwd))
(and (string=? (dir-1) tmp)
(string=? (dir-2) old)))
(λ ()
(rmdir tmp)))))
(test-end)