diff options
| -rw-r--r-- | build-aux/build-self.scm | 458 |
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 |