aboutsummaryrefslogtreecommitdiff
path: root/build-aux/build-self.scm
diff options
context:
space:
mode:
Diffstat (limited to 'build-aux/build-self.scm')
-rw-r--r--build-aux/build-self.scm458
1 files changed, 237 insertions, 221 deletions
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 4c85c09df6..5ec76a588f 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,254 @@
;;; 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))))
+ (match (get-string-all pipe)
+ ((? eof-object?)
+ (error "build program failed" build))
+ ((? 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
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-28 23:46:58 +0000