diff options
| -rw-r--r-- | bin/evaluate.in | 3 | ||||
| -rw-r--r-- | build-aux/pre-inst-env.in | 3 | ||||
| -rw-r--r-- | guix.scm | 82 | ||||
| -rw-r--r-- | guix/ci.scm | 22 | ||||
| -rw-r--r-- | tests/guix-track-git.scm | 221 | ||||
| -rw-r--r-- | tests/hello-git.scm | 53 |
6 files changed, 383 insertions, 1 deletions
diff --git a/bin/evaluate.in b/bin/evaluate.in index 767e15e..872d0b0 100644 --- a/bin/evaluate.in +++ b/bin/evaluate.in @@ -58,7 +58,8 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (parameterize ((%package-database database) (%use-substitutes? (assoc-ref spec #:use-substitutes?))) ;; Call the entry point of FILE and print the resulting job sexp. - (let* ((proc (module-ref %user-module 'hydra-jobs)) + (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)) diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in index e8d9487..b67dc5e 100644 --- a/build-aux/pre-inst-env.in +++ b/build-aux/pre-inst-env.in @@ -30,4 +30,7 @@ export CUIRASS_DATADIR PATH="$abs_top_builddir/bin:$PATH" export PATH +GUIX_PACKAGE_PATH="guix${GUIX_PACKAGE_PATH:+:}$GUIX_PACKAGE_PATH" +export GUIX_PACKAGE_PATH + exec "$@" diff --git a/guix.scm b/guix.scm new file mode 100644 index 0000000..b02ad85 --- /dev/null +++ b/guix.scm @@ -0,0 +1,82 @@ +;;; guix.scm -- Guix package definition +;;; 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/>. + +;;; Commentary: +;; +;; GNU Guix development package. To build and install, run: +;; +;; guix package -f guix.scm +;; +;; To build it, but not install it, run: +;; +;; guix build -f guix.scm +;; +;; To use as the basis for a development environment, run: +;; +;; guix environment -l guix.scm +;; +;;; Code: + +(use-modules (gnu packages) + (gnu packages autotools) + (gnu packages base) + (gnu packages databases) + (gnu packages guile) + (gnu packages package-management) + (gnu packages pkg-config) + (guix git-download) + (guix licenses) + (guix packages) + (guix build-system gnu)) + +(define-public cuirass + (package + (name "cuirass") + (version "0.0.ff7c3a1") + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://notabug.org/mthl/cuirass") + (commit "master"))) + (sha256 + (base32 + "1jw3smw6axqr58ahkyjncygv0nk3hdrqkv0hm4awwj0hg5nl3d2p")))) + (build-system gnu-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + (add-after 'unpack 'bootstrap + (lambda _ (zero? (system* "sh" "bootstrap"))))))) + (native-inputs + `(("autoconf" ,autoconf) + ("automake" ,automake) + ("guile" ,guile-2.0) + ("guile-json" ,guile-json) + ("guile-sqlite3" ,guile-sqlite3) + ("guix" ,guix) + ("pkg-config" ,pkg-config) + ("sqlite" ,sqlite))) + (synopsis "Continuous integration system") + (description + "Cuirass is a continuous integration system which uses GNU Guix. It is +intended as replacement for Hydra.") + (home-page "https://notabug.org/mthl/cuirass") + (license gpl3+))) + +;; Return it here so 'guix build/environment/package' can consume it directly. +cuirass diff --git a/guix/ci.scm b/guix/ci.scm new file mode 100644 index 0000000..997629d --- /dev/null +++ b/guix/ci.scm @@ -0,0 +1,22 @@ +;;; ci.scm -- Module for Guix package definition +;;; 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/>. + +;; Adding this directory to GUIX_PACKAGE_PATH exposes the Cuirass package to +;; Guix +(define-module (ci)) +(include "../guix.scm") diff --git a/tests/guix-track-git.scm b/tests/guix-track-git.scm new file mode 100644 index 0000000..10a3d48 --- /dev/null +++ b/tests/guix-track-git.scm @@ -0,0 +1,221 @@ +;;; 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))))) diff --git a/tests/hello-git.scm b/tests/hello-git.scm new file mode 100644 index 0000000..f6df99c --- /dev/null +++ b/tests/hello-git.scm @@ -0,0 +1,53 @@ +;;; 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)))) |