aboutsummaryrefslogtreecommitdiff
path: root/build-aux
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2018-04-16 18:15:28 +0200
committerMarius Bakke <mbakke@fastmail.com>2018-04-16 18:15:28 +0200
commit5d904d63f4d43e3f0e4be38c5f5404e029c00a22 (patch)
treeb2893eceae99c967e0f49cdbfe084f6c7d4767c4 /build-aux
parentbab5f3a7f62150ae009e78d03c4b1f5b1646104c (diff)
parentd0ee11b2f000c3c027fd8370bc2195266398444f (diff)
downloadgnu-guix-5d904d63f4d43e3f0e4be38c5f5404e029c00a22.tar
gnu-guix-5d904d63f4d43e3f0e4be38c5f5404e029c00a22.tar.gz
Merge branch 'master' into staging
Diffstat (limited to 'build-aux')
-rw-r--r--build-aux/build-self.scm460
-rw-r--r--build-aux/check-final-inputs-self-contained.scm36
-rw-r--r--build-aux/compile-as-derivation.scm53
-rw-r--r--build-aux/cuirass/gnu-system.scm28
-rw-r--r--build-aux/cuirass/guix-modular.scm6
-rw-r--r--build-aux/cuirass/hydra-to-cuirass.scm47
-rw-r--r--build-aux/hydra/evaluate.scm11
-rw-r--r--build-aux/hydra/gnu-system.scm11
-rw-r--r--build-aux/hydra/guix-modular.scm54
-rw-r--r--build-aux/hydra/guix.scm4
10 files changed, 400 insertions, 310 deletions
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 4c85c09df6..bccb7a959e 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,10 +19,14 @@
(define-module (build-self)
#:use-module (gnu)
#:use-module (guix)
+ #:use-module (guix ui)
#:use-module (guix config)
+ #:use-module (guix modules)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
+ #:use-module (rnrs io ports)
#:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
#:export (build))
;;; Commentary:
@@ -40,242 +44,256 @@
;;; Code:
-;; The dependencies. Don't refer explicitly to the variables because they
-;; could be renamed or shuffled around in modules over time. Conversely,
-;; 'find-best-packages-by-name' is expected to always have the same semantics.
-
-(define guix
- (first (find-best-packages-by-name "guix" #f)))
-
-(define libgcrypt
- (first (find-best-packages-by-name "libgcrypt" #f)))
-
-(define zlib
- (first (find-best-packages-by-name "zlib" #f)))
-
-(define gzip
- (first (find-best-packages-by-name "gzip" #f)))
-
-(define bzip2
- (first (find-best-packages-by-name "bzip2" #f)))
-
-(define xz
- (first (find-best-packages-by-name "xz" #f)))
-
-(define (false-if-wrong-guile package)
- "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g.,
-2.0 instead of 2.2), otherwise return PACKAGE."
- (let ((guile (any (match-lambda
- ((label (? package? dep) _ ...)
- (and (string=? (package-name dep) "guile")
- dep)))
- (package-direct-inputs package))))
- (and (or (not guile)
- (string-prefix? (effective-version)
- (package-version guile)))
- package)))
-
-(define (package-for-current-guile . names)
- "Return the package with one of the given NAMES that depends on the current
-Guile major version (2.0 or 2.2), or #f if none of the packages matches."
- (let loop ((names names))
- (match names
- (()
- #f)
- ((name rest ...)
- (match (find-best-packages-by-name name #f)
- (()
- (loop rest))
- ((first _ ...)
- (or (false-if-wrong-guile first)
- (loop rest))))))))
-
-(define guile-json
- (package-for-current-guile "guile-json"
- "guile2.2-json"
- "guile2.0-json"))
-
-(define guile-ssh
- (package-for-current-guile "guile-ssh"
- "guile2.2-ssh"
- "guile2.0-ssh"))
-
-(define guile-git
- (package-for-current-guile "guile-git"
- "guile2.0-git"))
-
-(define guile-bytestructures
- (package-for-current-guile "guile-bytestructures"
- "guile2.0-bytestructures"))
-
-;; The actual build procedure.
+;;;
+;;; Generating (guix config).
+;;;
+;;; This is copied from (guix self) because we cannot assume (guix self) is
+;;; available at this point.
+;;;
+
+(define %dependency-variables
+ ;; (guix config) variables corresponding to dependencies.
+ '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate))
+
+(define %persona-variables
+ ;; (guix config) variables that define Guix's persona.
+ '(%guix-package-name
+ %guix-version
+ %guix-bug-report-address
+ %guix-home-page-url))
+
+(define %config-variables
+ ;; (guix config) variables corresponding to Guix configuration (storedir,
+ ;; localstatedir, etc.)
+ (sort (filter pair?
+ (module-map (lambda (name var)
+ (and (not (memq name %dependency-variables))
+ (not (memq name %persona-variables))
+ (cons name (variable-ref var))))
+ (resolve-interface '(guix config))))
+ (lambda (name+value1 name+value2)
+ (string<? (symbol->string (car name+value1))
+ (symbol->string (car name+value2))))))
+
+(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
+ (package-name "GNU Guix")
+ (package-version "0")
+ (bug-report-address "bug-guix@gnu.org")
+ (home-page-url "https://gnu.org/s/guix"))
+
+ ;; Hack so that Geiser is not confused.
+ (define defmod 'define-module)
+
+ (scheme-file "config.scm"
+ #~(begin
+ (#$defmod (guix config)
+ #:export (%guix-package-name
+ %guix-version
+ %guix-bug-report-address
+ %guix-home-page-url
+ %libgcrypt
+ %libz
+ %gzip
+ %bzip2
+ %xz
+ %nix-instantiate))
+
+ ;; XXX: Work around <http://bugs.gnu.org/15602>.
+ (eval-when (expand load eval)
+ #$@(map (match-lambda
+ ((name . value)
+ #~(define-public #$name #$value)))
+ %config-variables)
+
+ (define %guix-package-name #$package-name)
+ (define %guix-version #$package-version)
+ (define %guix-bug-report-address #$bug-report-address)
+ (define %guix-home-page-url #$home-page-url)
+
+ (define %gzip
+ #+(and gzip (file-append gzip "/bin/gzip")))
+ (define %bzip2
+ #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
+ (define %xz
+ #+(and xz (file-append xz "/bin/xz")))
+
+ (define %libgcrypt
+ #+(and libgcrypt
+ (file-append libgcrypt "/lib/libgcrypt")))
+ (define %libz
+ #+(and zlib
+ (file-append zlib "/lib/libz")))
+
+ (define %nix-instantiate ;for (guix import snix)
+ "nix-instantiate")))))
-(define (top-source-directory)
- "Return the name of the top-level directory of this source tree."
- (and=> (assoc-ref (current-source-location) 'filename)
- (lambda (file)
- (string-append (dirname file) "/.."))))
+
+;;;
+;;; 'gexp->script'.
+;;;
+;;; This is our own variant of 'gexp->script' with an extra #:module-path
+;;; parameter, which was unavailable in (guix gexp) until commit
+;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
+;;;
+(define (load-path-expression modules path)
+ "Return as a monadic value a gexp that sets '%load-path' and
+'%load-compiled-path' to point to MODULES, a list of module names. MODULES
+are searched for in PATH."
+ (mlet %store-monad ((modules (imported-modules modules
+ #:module-path path))
+ (compiled (compiled-modules modules
+ #:module-path path)))
+ (return (gexp (eval-when (expand load eval)
+ (set! %load-path
+ (cons (ungexp modules) %load-path))
+ (set! %load-compiled-path
+ (cons (ungexp compiled)
+ %load-compiled-path)))))))
+
+(define* (gexp->script name exp
+ #:key (guile (default-guile))
+ (module-path %load-path))
+ "Return an executable script NAME that runs EXP using GUILE, with EXP's
+imported modules in its search path."
+ (mlet %store-monad ((set-load-path
+ (load-path-expression (gexp-modules exp)
+ module-path)))
+ (gexp->derivation name
+ (gexp
+ (call-with-output-file (ungexp output)
+ (lambda (port)
+ ;; Note: that makes a long shebang. When the store
+ ;; is /gnu/store, that fits within the 128-byte
+ ;; limit imposed by Linux, but that may go beyond
+ ;; when running tests.
+ (format port
+ "#!~a/bin/guile --no-auto-compile~%!#~%"
+ (ungexp guile))
+
+ (write '(ungexp set-load-path) port)
+ (write '(ungexp exp) port)
+ (chmod port #o555))))
+ #:module-path module-path)))
+
(define (date-version-string)
"Return the current date and hour in UTC timezone, for use as a poor
person's version identifier."
;; XXX: Replace with a Git commit id.
(date->string (current-date 0) "~Y~m~d.~H"))
-(define (matching-guile-2.2)
- "Return a Guile 2.2 with the same version as the current one or immediately
-older than then current one. This is so that we do not build ABI-incompatible
-objects. See <https://bugs.gnu.org/29570>."
- (let loop ((packages (find-packages-by-name "guile" "2.2"))
- (best #f))
- (match packages
- (()
- best)
- ((head tail ...)
- (if (string=? (package-version head) (version))
- head
- (if best
- (if (version>? (package-version head) (version))
- (loop tail best)
- (loop tail head))
- (loop tail head)))))))
-
-(define (guile-for-build)
- "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
-running Guile."
- (package->derivation (cond-expand
- (guile-2.2
- (canonical-package (matching-guile-2.2)))
- (else
- (canonical-package
- (specification->package "guile@2.0"))))))
+(define* (build-program source version
+ #:optional (guile-version (effective-version)))
+ "Return a program that computes the derivation to build Guix from SOURCE."
+ (define select?
+ ;; Select every module but (guix config) and non-Guix modules.
+ (match-lambda
+ (('guix 'config) #f)
+ (('guix _ ...) #t)
+ (('gnu _ ...) #t)
+ (_ #f)))
+
+ (with-imported-modules `(((guix config)
+ => ,(make-config.scm
+ #:libgcrypt
+ (specification->package "libgcrypt")))
+ ,@(source-module-closure `((guix store)
+ (guix self)
+ (guix derivations)
+ (gnu packages bootstrap))
+ (list source)
+ #:select? select?))
+ (gexp->script "compute-guix-derivation"
+ #~(begin
+ (use-modules (ice-9 match))
+
+ (eval-when (expand load eval)
+ ;; Don't augment '%load-path'.
+ (unsetenv "GUIX_PACKAGE_PATH")
+
+ ;; (gnu packages …) modules are going to be looked up
+ ;; under SOURCE. (guix config) is looked up in FRONT.
+ (match %load-path
+ ((#$source _ ...)
+ #t) ;already done
+ ((front _ ...)
+ (set! %load-path (list #$source front))))
+
+ ;; Only load our own modules or those of Guile.
+ (match %load-compiled-path
+ ((front _ ... sys1 sys2)
+ (set! %load-compiled-path
+ (list front sys1 sys2)))))
+
+ (use-modules (guix store)
+ (guix self)
+ (guix derivations)
+ (srfi srfi-1))
+
+ (define (spin system)
+ (define spin
+ (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
+
+ (format (current-error-port)
+ "Computing Guix derivation for '~a'... "
+ system)
+ (let loop ((spin spin))
+ (display (string-append "\b" (car spin))
+ (current-error-port))
+ (force-output (current-error-port))
+ (sleep 1)
+ (loop (cdr spin))))
+
+ (match (command-line)
+ ((_ _ system)
+ (with-store store
+ (call-with-new-thread
+ (lambda ()
+ (spin system)))
+
+ (display
+ (derivation-file-name
+ (run-with-store store
+ (guix-derivation #$source #$version
+ #$guile-version)
+ #:system system)))))))
+ #:module-path (list source))))
;; The procedure below is our return value.
(define* (build source
- #:key verbose? (version (date-version-string))
+ #:key verbose? (version (date-version-string)) system
+ (guile-version (match ((@ (guile) version))
+ ("2.2.2" "2.2.2")
+ (_ (effective-version))))
#:allow-other-keys
#:rest rest)
"Return a derivation that unpacks SOURCE into STORE and compiles Scheme
files."
- ;; The '%xxxdir' variables were added to (guix config) in July 2016 so we
- ;; cannot assume that they are defined. Try to guess their value when
- ;; they're undefined (XXX: we get an incorrect guess when environment
- ;; variables such as 'NIX_STATE_DIR' are defined!).
- (define storedir
- (if (defined? '%storedir) %storedir %store-directory))
- (define localstatedir
- (if (defined? '%localstatedir) %localstatedir (dirname %state-directory)))
- (define sysconfdir
- (if (defined? '%sysconfdir) %sysconfdir (dirname %config-directory)))
-
- (define builder
- #~(begin
- (use-modules (guix build pull))
-
- (letrec-syntax ((maybe-load-path
- (syntax-rules ()
- ((_ item rest ...)
- (let ((tail (maybe-load-path rest ...)))
- (if (string? item)
- (cons (string-append item
- "/share/guile/site/"
- #$(effective-version))
- tail)
- tail)))
- ((_)
- '()))))
- (set! %load-path
- (append
- (maybe-load-path #$guile-json #$guile-ssh
- #$guile-git #$guile-bytestructures)
- %load-path)))
-
- (letrec-syntax ((maybe-load-compiled-path
- (syntax-rules ()
- ((_ item rest ...)
- (let ((tail (maybe-load-compiled-path rest ...)))
- (if (string? item)
- (cons (string-append item
- "/lib/guile/"
- #$(effective-version)
- "/site-ccache")
- tail)
- tail)))
- ((_)
- '()))))
- (set! %load-compiled-path
- (append
- (maybe-load-compiled-path #$guile-json #$guile-ssh
- #$guile-git #$guile-bytestructures)
- %load-compiled-path)))
-
- ;; XXX: The 'guile-ssh' package prior to Guix commit 92b7258 was
- ;; broken: libguile-ssh could not be found. Work around that.
- ;; FIXME: We want Guile-SSH 0.10.2 or later anyway.
- #$(if (string-prefix? "0.9." (package-version guile-ssh))
- #~(setenv "LTDL_LIBRARY_PATH" (string-append #$guile-ssh "/lib"))
- #t)
-
- (build-guix #$output #$source
-
- #:system #$%system
- #:storedir #$storedir
- #:localstatedir #$localstatedir
- #:sysconfdir #$sysconfdir
- #:sbindir (string-append #$guix "/sbin")
-
- #:package-name #$%guix-package-name
- #:package-version #$version
- #:bug-report-address #$%guix-bug-report-address
- #:home-page-url #$%guix-home-page-url
-
- #:libgcrypt #$libgcrypt
- #:zlib #$zlib
- #:gzip #$gzip
- #:bzip2 #$bzip2
- #:xz #$xz
-
- ;; XXX: This is not perfect, enabling VERBOSE? means
- ;; building a different derivation.
- #:debug-port (if #$verbose?
- (current-error-port)
- (%make-void-port "w")))))
-
- (unless guile-git
- ;; XXX: Guix before February 2017 lacks a 'guile-git' package altogether.
- ;; If we try to upgrade anyway, the logic in (guix scripts pull) will not
- ;; build (guix git), which will leave us with an unusable 'guix pull'. To
- ;; avoid that, fail early.
- (format (current-error-port)
- "\
-Your installation is too old and lacks a '~a' package.
-Please upgrade to an intermediate version first, for instance with:
-
- guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.13.0.tar.gz
-\n"
- (match (effective-version)
- ("2.0" "guile2.0-git")
- (_ "guile-git")))
- (exit 1))
-
- (mlet %store-monad ((guile (guile-for-build)))
- (gexp->derivation "guix-latest" builder
- #:modules '((guix build pull)
- (guix build utils)
- (guix build compile)
-
- ;; Closure of (guix modules).
- (guix modules)
- (guix memoization)
- (guix profiling)
- (guix sets))
-
- ;; Arrange so that our own (guix build …) modules are
- ;; used.
- #:module-path (list (top-source-directory))
-
- #:guile-for-build guile)))
+ ;; Build the build program and then use it as a trampoline to build from
+ ;; SOURCE.
+ (mlet %store-monad ((build (build-program source version guile-version))
+ (system (if system (return system) (current-system))))
+ (mbegin %store-monad
+ (show-what-to-build* (list build))
+ (built-derivations (list build))
+ (let* ((pipe (begin
+ (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
+ (open-pipe* OPEN_READ
+ (derivation->output-path build)
+ source system)))
+ (str (get-string-all pipe))
+ (status (close-pipe pipe)))
+ (match str
+ ((? eof-object?)
+ (error "build program failed" (list build status)))
+ ((? derivation-path? drv)
+ (mbegin %store-monad
+ (return (newline (current-output-port)))
+ ((store-lift add-temp-root) drv)
+ (return (read-derivation-from-file drv))))
+ ((? string? str)
+ (error "invalid build result" (list build str))))))))
;; This file is loaded by 'guix pull'; return it the build procedure.
build
diff --git a/build-aux/check-final-inputs-self-contained.scm b/build-aux/check-final-inputs-self-contained.scm
index dfb6a72f24..37dc883d3c 100644
--- a/build-aux/check-final-inputs-self-contained.scm
+++ b/build-aux/check-final-inputs-self-contained.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -33,23 +33,23 @@
(define (final-inputs store system)
"Return the list of outputs directories of the final inputs for SYSTEM."
(append-map (match-lambda
- ((name package)
- (let ((drv (package-derivation store package system)))
- ;; Libc's 'debug' output refers to gcc-cross-boot0, but it's
- ;; hard to avoid, so we tolerate it. This should be the
- ;; only exception. Likewise, 'bash:include' depends on
- ;; bootstrap-binaries via its 'Makefile.inc' (FIXME).
- (filter-map (match-lambda
- (("debug" . directory)
- (if (string=? "glibc" (package-name package))
- #f
- directory))
- (("include" . directory)
- (if (string=? "bash" (package-name package))
- #f
- directory))
- ((_ . directory) directory))
- (derivation->output-paths drv)))))
+ ((or (name package) (name package _))
+ (let ((drv (package-derivation store package system)))
+ ;; Libc's 'debug' output refers to gcc-cross-boot0, but it's
+ ;; hard to avoid, so we tolerate it. This should be the
+ ;; only exception. Likewise, 'bash:include' depends on
+ ;; bootstrap-binaries via its 'Makefile.inc' (FIXME).
+ (filter-map (match-lambda
+ (("debug" . directory)
+ (if (string=? "glibc" (package-name package))
+ #f
+ directory))
+ (("include" . directory)
+ (if (string=? "bash" (package-name package))
+ #f
+ directory))
+ ((_ . directory) directory))
+ (derivation->output-paths drv)))))
%final-inputs))
(define (assert-valid-substitute substitute)
diff --git a/build-aux/compile-as-derivation.scm b/build-aux/compile-as-derivation.scm
new file mode 100644
index 0000000000..afb134a92a
--- /dev/null
+++ b/build-aux/compile-as-derivation.scm
@@ -0,0 +1,53 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; 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/>.
+
+;; Build Guix using Guix.
+
+(use-modules (srfi srfi-26))
+
+;; Add ~/.config/guix/latest to the search path.
+(add-to-load-path
+ (and=> (or (getenv "XDG_CONFIG_HOME")
+ (and=> (getenv "HOME")
+ (cut string-append <> "/.config")))
+ (cut string-append <> "/guix/latest")))
+
+(use-modules (guix) (guix ui)
+ (guix git-download)
+ (ice-9 match))
+
+(match (command-line)
+ ((program source)
+ (with-error-handling
+ (with-store store
+ (let* ((script (string-append source "/build-aux/build-self.scm"))
+ (build (primitive-load script))
+ (git? (git-predicate source)))
+ (run-with-store store
+ ;; TODO: Extract #:version and #:commit using Guile-Git.
+ (mlet* %store-monad ((source (interned-file source "guix-source"
+ #:select? git?
+ #:recursive? #t))
+ (drv (build source)))
+ (mbegin %store-monad
+ (show-what-to-build* (list drv))
+ (built-derivations (list drv))
+ (with-monad %store-monad
+ (display (derivation->output-path drv))
+ (newline)
+ (return drv))))))))))
diff --git a/build-aux/cuirass/gnu-system.scm b/build-aux/cuirass/gnu-system.scm
index f545ba03bc..0eb834cfba 100644
--- a/build-aux/cuirass/gnu-system.scm
+++ b/build-aux/cuirass/gnu-system.scm
@@ -21,29 +21,5 @@
;;; tool.
;;;
-(include-from-path "build-aux/hydra/gnu-system.scm")
-
-(use-modules ((guix licenses)
- #:select (license? license-name license-uri license-comment)))
-
-(define (cuirass-jobs store arguments)
- "Return Cuirass jobs."
- (map hydra-job->cuirass-job (hydra-jobs store arguments)))
-
-(define (hydra-job->cuirass-job hydra-job)
- (let ((name (car hydra-job))
- (job ((cdr hydra-job))))
- (lambda _ (acons #:job-name (symbol->string name)
- (map symbol-alist-entry->keyword-alist-entry job)))))
-
-(define (symbol-alist-entry->keyword-alist-entry entry)
- (cons (symbol->keyword (car entry)) (entry->sexp-entry (cdr entry))))
-
-(define (entry->sexp-entry o)
- (match o
- ((? license?) `((name . (license-name o))
- (uri . ,(license-uri o))
- (comment . ,(license-comment o))))
- ((lst ...)
- (map entry->sexp-entry lst))
- (_ o)))
+(include "../hydra/gnu-system.scm")
+(include "hydra-to-cuirass.scm")
diff --git a/build-aux/cuirass/guix-modular.scm b/build-aux/cuirass/guix-modular.scm
new file mode 100644
index 0000000000..cbbdbf1133
--- /dev/null
+++ b/build-aux/cuirass/guix-modular.scm
@@ -0,0 +1,6 @@
+;;;
+;;; This file defines Cuirass build jobs to build Guix itself.
+;;;
+
+(include "../hydra/guix-modular.scm")
+(include "hydra-to-cuirass.scm")
diff --git a/build-aux/cuirass/hydra-to-cuirass.scm b/build-aux/cuirass/hydra-to-cuirass.scm
new file mode 100644
index 0000000000..75c77ea35a
--- /dev/null
+++ b/build-aux/cuirass/hydra-to-cuirass.scm
@@ -0,0 +1,47 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; 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 the conversion of Hydra build jobs to Cuirass build
+;;; jobs. It is meant to be included in other files.
+;;;
+
+(use-modules ((guix licenses)
+ #:select (license? license-name license-uri license-comment)))
+
+(define (cuirass-jobs store arguments)
+ "Return Cuirass jobs."
+ (map hydra-job->cuirass-job (hydra-jobs store arguments)))
+
+(define (hydra-job->cuirass-job hydra-job)
+ (let ((name (car hydra-job))
+ (job ((cdr hydra-job))))
+ (lambda _ (acons #:job-name (symbol->string name)
+ (map symbol-alist-entry->keyword-alist-entry job)))))
+
+(define (symbol-alist-entry->keyword-alist-entry entry)
+ (cons (symbol->keyword (car entry)) (entry->sexp-entry (cdr entry))))
+
+(define (entry->sexp-entry o)
+ (match o
+ ((? license?) `((name . (license-name o))
+ (uri . ,(license-uri o))
+ (comment . ,(license-comment o))))
+ ((lst ...)
+ (map entry->sexp-entry lst))
+ (_ o)))
diff --git a/build-aux/hydra/evaluate.scm b/build-aux/hydra/evaluate.scm
index 8e391f44fd..5793c022ff 100644
--- a/build-aux/hydra/evaluate.scm
+++ b/build-aux/hydra/evaluate.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
@@ -79,7 +79,8 @@ Otherwise return THING."
(match (command-line)
((command file cuirass? ...)
;; Load FILE, a Scheme file that defines Hydra jobs.
- (let ((port (current-output-port)))
+ (let ((port (current-output-port))
+ (real-build-things build-things))
(save-module-excursion
(lambda ()
(set-current-module %user-module)
@@ -93,13 +94,15 @@ Otherwise return THING."
;; Grafts can trigger early builds. We do not want that to happen
;; during evaluation, so use a sledgehammer to catch such problems.
+ ;; An exception, though, is the evaluation of Guix itself, which
+ ;; requires building a "trampoline" program.
(set! build-things
(lambda (store . args)
(format (current-error-port)
- "error: trying to build things during evaluation!~%")
+ "warning: building things during evaluation~%")
(format (current-error-port)
"'build-things' arguments: ~s~%" args)
- (exit 1)))
+ (apply real-build-things store args)))
;; Call the entry point of FILE and print the resulting job sexp.
(pretty-print
diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm
index 8178871747..62eb957f83 100644
--- a/build-aux/hydra/gnu-system.scm
+++ b/build-aux/hydra/gnu-system.scm
@@ -24,7 +24,7 @@
(use-modules (system base compile))
-(eval-when (compile load eval)
+(eval-when (expand load eval)
;; Pre-load the compiler so we don't end up auto-compiling it.
(compile #t)
@@ -32,6 +32,15 @@
;; Use our very own Guix modules.
(set! %fresh-auto-compile #t)
+ ;; Ignore .go files except for Guile's. 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. Use 'reverse' so that /gnu/store/…-guile
+ ;; comes before /run/current-system/profile.
+ (set! %load-compiled-path
+ (list
+ (dirname (dirname (search-path (reverse %load-compiled-path)
+ "ice-9/boot-9.go")))))
+
(and=> (assoc-ref (current-source-location) 'filename)
(lambda (file)
(let ((dir (string-append (dirname file) "/../..")))
diff --git a/build-aux/hydra/guix-modular.scm b/build-aux/hydra/guix-modular.scm
index bdbb2fa8d5..58e09e1831 100644
--- a/build-aux/hydra/guix-modular.scm
+++ b/build-aux/hydra/guix-modular.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,35 +21,14 @@
;;; Guix as 'guix pull', which is defined in (guix self).
;;;
-;; Attempt to use our very own Guix modules.
-(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)
-
- (and=> (assoc-ref (current-source-location) 'filename)
- (lambda (file)
- (let ((dir (canonicalize-path
- (string-append (dirname file) "/../.."))))
- (format (current-error-port) "prepending ~s to the load path~%"
- dir)
- (set! %load-path (cons dir %load-path))))))
-
-
(use-modules (guix store)
(guix config)
(guix utils)
- (guix grafts)
((guix packages) #:select (%hydra-supported-systems))
(guix derivations)
(guix monads)
- (guix gexp)
- (guix self)
((guix licenses) #:prefix license:)
(srfi srfi-1)
- (srfi srfi-26)
(ice-9 match))
;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
@@ -61,11 +40,13 @@
"Return a Hydra job a list building the modular Guix derivation from SOURCE
for SYSTEM. Use VERSION as the version identifier."
(lambda ()
+ (define build
+ (primitive-load (string-append source "/build-aux/build-self.scm")))
+
`((derivation . ,(derivation-file-name
- (parameterize ((%graft? #f))
- (run-with-store store
- (lower-object (compiled-guix source
- #:version version))))))
+ (run-with-store store
+ (build source #:version version #:system system
+ #:guile-version "2.2")))) ;the latest 2.2.x
(description . "Modular Guix")
(long-description
. "This is the modular Guix package as produced by 'guix pull'.")
@@ -76,29 +57,26 @@ for SYSTEM. Use VERSION as the version identifier."
(define (hydra-jobs store arguments)
"Return Hydra jobs."
(define systems
- (match (filter-map (match-lambda
- (('system . value) value)
- (_ #f))
- arguments)
- ((lst ..1)
- lst)
- (_
- (list (%current-system)))))
+ (match (assoc-ref arguments 'systems)
+ (#f %hydra-supported-systems)
+ ((lst ...) lst)
+ ((? string? str) (call-with-input-string str read))))
(define guix-checkout
- (assq-ref arguments 'guix))
+ (or (assq-ref arguments 'guix) ;Hydra on hydra
+ (assq-ref arguments 'guix-modular))) ;Cuirass on berlin
(define version
(or (assq-ref guix-checkout 'revision)
"0.unknown"))
(let ((file (assq-ref guix-checkout 'file-name)))
- (format (current-error-port) "using checkout ~s (~s)~%"
- guix-checkout file)
+ (format (current-error-port) "using checkout ~s (~s; arguments: ~s)~%"
+ guix-checkout file arguments)
(map (lambda (system)
(let ((name (string->symbol
(string-append "guix." system))))
`(,name
. ,(build-job store file version system))))
- %hydra-supported-systems)))
+ systems)))
diff --git a/build-aux/hydra/guix.scm b/build-aux/hydra/guix.scm
index 659b8bfbc1..08193ec82e 100644
--- a/build-aux/hydra/guix.scm
+++ b/build-aux/hydra/guix.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,7 +22,7 @@
;;;
;; Attempt to use our very own Guix modules.
-(eval-when (compile load eval)
+(eval-when (expand 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