From e9e1ce8e14ffdbd8ddddaacc93e0e71d0c29a992 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Fri, 16 Dec 2016 13:20:49 +0100 Subject: maint: Move examples from 'tests' to 'examples' directory. * examples/gnu-system.scm: Moved from 'tests' directory. * examples/guix-jobs.scm: Likewise. * examples/guix-track-git.scm: Likewise. * examples/hello-git.scm: Likewise. * examples/hello-singleton.scm: Likewise. * examples/hello-subset.scm: Likewise. * Makefile.am (EXTRA_DIST): Adapt. * README : Likewise. --- Makefile.am | 8 +- README | 4 +- examples/gnu-system.scm | 231 +++++++++++++++++++++++++++++++++++++++++++ examples/guix-jobs.scm | 37 +++++++ examples/guix-track-git.scm | 221 +++++++++++++++++++++++++++++++++++++++++ examples/hello-git.scm | 53 ++++++++++ examples/hello-singleton.scm | 33 +++++++ examples/hello-subset.scm | 43 ++++++++ tests/gnu-system.scm | 231 ------------------------------------------- tests/guix-jobs.scm | 37 ------- tests/guix-track-git.scm | 221 ----------------------------------------- tests/hello-git.scm | 53 ---------- tests/hello-singleton.scm | 33 ------- tests/hello-subset.scm | 43 -------- 14 files changed, 624 insertions(+), 624 deletions(-) create mode 100644 examples/gnu-system.scm create mode 100644 examples/guix-jobs.scm create mode 100644 examples/guix-track-git.scm create mode 100644 examples/hello-git.scm create mode 100644 examples/hello-singleton.scm create mode 100644 examples/hello-subset.scm delete mode 100644 tests/gnu-system.scm delete mode 100644 tests/guix-jobs.scm delete mode 100644 tests/guix-track-git.scm delete mode 100644 tests/hello-git.scm delete mode 100644 tests/hello-singleton.scm delete mode 100644 tests/hello-subset.scm diff --git a/Makefile.am b/Makefile.am index d198e01..99d2b4b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -113,10 +113,10 @@ EXTRA_DIST = \ bin/evaluate.in \ bootstrap \ src/cuirass/config.scm.in \ - tests/gnu-system.scm \ - tests/guix-jobs.scm \ - tests/hello-singleton.scm \ - tests/hello-subset.scm \ + examples/gnu-system.scm \ + examples/guix-jobs.scm \ + examples/hello-singleton.scm \ + examples/hello-subset.scm \ $(TESTS) MOSTLYCLEANFILES = $(bin_SCRIPTS) src/cuirass/config.scm diff --git a/README b/README index 41cca7c..a0b3159 100644 --- a/README +++ b/README @@ -26,9 +26,9 @@ Example A quick way to manually test Cuirass is to execute: - ./pre-inst-env cuirass --specifications=tests/hello-singleton.scm --database=test.db + ./pre-inst-env cuirass --specifications=examples/hello-singleton.scm --database=test.db -This will read the file "tests/hello-singleton.scm" which contains a list of +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. diff --git a/examples/gnu-system.scm b/examples/gnu-system.scm new file mode 100644 index 0000000..8e29fec --- /dev/null +++ b/examples/gnu-system.scm @@ -0,0 +1,231 @@ +;;;; gnu-system.scm - build jobs for Guix +;;; +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2016 Mathieu Lirzin +;;; +;;; 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 . + +;; 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 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))) diff --git a/examples/guix-jobs.scm b/examples/guix-jobs.scm new file mode 100644 index 0000000..862cff7 --- /dev/null +++ b/examples/guix-jobs.scm @@ -0,0 +1,37 @@ +;;; guix-jobs.scm -- job specification test for Guix +;;; Copyright © 2016 Mathieu Lirzin +;;; +;;; 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 . + +(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) diff --git a/examples/guix-track-git.scm b/examples/guix-track-git.scm new file mode 100644 index 0000000..10a3d48 --- /dev/null +++ b/examples/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 +;;; Copyright © 2016 Mathieu Lirzin +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; +;;; 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 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/examples/hello-git.scm b/examples/hello-git.scm new file mode 100644 index 0000000..f6df99c --- /dev/null +++ b/examples/hello-git.scm @@ -0,0 +1,53 @@ +;;; hello-git.scm -- job specification test for hello git repository +;;; Copyright © 2016 Mathieu Lirzin +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +(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)))) diff --git a/examples/hello-singleton.scm b/examples/hello-singleton.scm new file mode 100644 index 0000000..5ff2e82 --- /dev/null +++ b/examples/hello-singleton.scm @@ -0,0 +1,33 @@ +;;; hello-singleton.scm -- job specification test for hello in master +;;; Copyright © 2016 Mathieu Lirzin +;;; +;;; 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 . + +(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) diff --git a/examples/hello-subset.scm b/examples/hello-subset.scm new file mode 100644 index 0000000..60764fc --- /dev/null +++ b/examples/hello-subset.scm @@ -0,0 +1,43 @@ +;;; hello-subset.scm -- job specification test for hello subset +;;; Copyright © 2016 Mathieu Lirzin +;;; +;;; 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 . + +(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) diff --git a/tests/gnu-system.scm b/tests/gnu-system.scm deleted file mode 100644 index 8e29fec..0000000 --- a/tests/gnu-system.scm +++ /dev/null @@ -1,231 +0,0 @@ -;;;; gnu-system.scm - build jobs for Guix -;;; -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès -;;; Copyright © 2016 Mathieu Lirzin -;;; -;;; 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 . - -;; 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 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))) diff --git a/tests/guix-jobs.scm b/tests/guix-jobs.scm deleted file mode 100644 index 862cff7..0000000 --- a/tests/guix-jobs.scm +++ /dev/null @@ -1,37 +0,0 @@ -;;; guix-jobs.scm -- job specification test for Guix -;;; Copyright © 2016 Mathieu Lirzin -;;; -;;; 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 . - -(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) diff --git a/tests/guix-track-git.scm b/tests/guix-track-git.scm deleted file mode 100644 index 10a3d48..0000000 --- a/tests/guix-track-git.scm +++ /dev/null @@ -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 -;;; Copyright © 2016 Mathieu Lirzin -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; 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 . - -;;; -;;; 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 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 deleted file mode 100644 index f6df99c..0000000 --- a/tests/hello-git.scm +++ /dev/null @@ -1,53 +0,0 @@ -;;; hello-git.scm -- job specification test for hello git repository -;;; Copyright © 2016 Mathieu Lirzin -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; 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 . - -(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)))) diff --git a/tests/hello-singleton.scm b/tests/hello-singleton.scm deleted file mode 100644 index 5ff2e82..0000000 --- a/tests/hello-singleton.scm +++ /dev/null @@ -1,33 +0,0 @@ -;;; hello-singleton.scm -- job specification test for hello in master -;;; Copyright © 2016 Mathieu Lirzin -;;; -;;; 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 . - -(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) diff --git a/tests/hello-subset.scm b/tests/hello-subset.scm deleted file mode 100644 index 60764fc..0000000 --- a/tests/hello-subset.scm +++ /dev/null @@ -1,43 +0,0 @@ -;;; hello-subset.scm -- job specification test for hello subset -;;; Copyright © 2016 Mathieu Lirzin -;;; -;;; 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 . - -(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) -- cgit v1.2.3