diff options
author | Mathieu Lirzin <mthl@gnu.org> | 2016-12-16 13:20:49 +0100 |
---|---|---|
committer | Mathieu Lirzin <mthl@gnu.org> | 2016-12-16 13:20:49 +0100 |
commit | e9e1ce8e14ffdbd8ddddaacc93e0e71d0c29a992 (patch) | |
tree | 856b9a457bc63667efbfb6f962be957fdd2f79ae /tests/gnu-system.scm | |
parent | 5dc1bf40e96ee40f9e786ffeafc3eb895b4e8e74 (diff) | |
download | cuirass-e9e1ce8e14ffdbd8ddddaacc93e0e71d0c29a992.tar cuirass-e9e1ce8e14ffdbd8ddddaacc93e0e71d0c29a992.tar.gz |
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 <Example>: Likewise.
Diffstat (limited to 'tests/gnu-system.scm')
-rw-r--r-- | tests/gnu-system.scm | 231 |
1 files changed, 0 insertions, 231 deletions
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 <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))) |