From f81ac34dd9ab0f2ebaabf2cf382bd52d0d78396a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 9 Nov 2014 22:32:21 +0100 Subject: pull: Use the build procedure provided by the newly-downloaded Guix. Fixes . * guix/scripts/pull.scm (with-environment-variable, with-PATH): New macros. (temporary-directory, first-directory, interned-then-deleted): New procedures. (unpack): Rewrite to do the unpacking in the current process rather than as a separate derivation. (%self-build-file): New variable. (build-from-source): New procedure. (build-and-install): Use it. * guix/build/pull.scm (build-guix): Rename 'tarball' argument to 'source'. Remove #:tar and #:gzip parameters, as well as 'tar' invocation. Remove 'scandir' invocation. Wrap body in 'with-directory-excursion'. * build-aux/build-self.scm: New file. * Makefile.am (EXTRA_DIST): Add it. --- Makefile.am | 1 + build-aux/build-self.scm | 98 +++++++++++++++++++++++++++++++++++++ guix/build/pull.scm | 120 +++++++++++++++++++++------------------------- guix/scripts/pull.scm | 122 +++++++++++++++++++++++++++++++++++++---------- 4 files changed, 250 insertions(+), 91 deletions(-) create mode 100644 build-aux/build-self.scm diff --git a/Makefile.am b/Makefile.am index b13fcbc053..3350fd6994 100644 --- a/Makefile.am +++ b/Makefile.am @@ -223,6 +223,7 @@ EXTRA_DIST = \ ROADMAP \ TODO \ .dir-locals.el \ + build-aux/build-self.scm \ build-aux/hydra/gnu-system.scm \ build-aux/hydra/demo-os.scm \ build-aux/hydra/guix.scm \ diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm new file mode 100644 index 0000000000..b78f3cb437 --- /dev/null +++ b/build-aux/build-self.scm @@ -0,0 +1,98 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (build-self) + #:use-module (gnu) + #:use-module (guix) + #:use-module (srfi srfi-1) + #:export (build)) + +;;; Commentary: +;;; +;;; When loaded, this module returns a monadic procedure of at least one +;;; argument: the source tree to build. It returns a derivation that +;;; builds it. +;;; +;;; This file uses modules provided by the already-installed Guix. Those +;;; modules may be arbitrarily old compared to the version we want to +;;; build. Because of that, it must rely on the smallest set of features +;;; that are likely to be provided by the (guix) and (gnu) modules, and by +;;; Guile itself, forever and ever. +;;; +;;; 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 libgcrypt + (first (find-best-packages-by-name "libgcrypt" #f))) + +(define guile-json + (first (find-best-packages-by-name "guile-json" #f))) + + + +;; The actual build procedure. + +(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) "/..")))) + +;; The procedure below is our return value. +(define* (build source #:key verbose? + #:allow-other-keys + #:rest rest) + "Return a derivation that unpacks SOURCE into STORE and compiles Scheme +files." + (define builder + #~(begin + (use-modules (guix build pull)) + + (let ((json (string-append #$guile-json "/share/guile/site/2.0"))) + (set! %load-path (cons json %load-path)) + (set! %load-compiled-path (cons json %load-compiled-path))) + + (build-guix #$output #$source + + ;; XXX: This is not perfect, enabling VERBOSE? means + ;; building a different derivation. + #:debug-port (if #$verbose? + (current-error-port) + (%make-void-port "w")) + #:gcrypt #$libgcrypt))) + + (gexp->derivation "guix-latest" builder + #:modules '((guix build pull) + (guix build utils)) + + ;; Arrange so that our own (guix build …) modules are + ;; used. + #:module-path (list (top-source-directory)))) + +;; This file is loaded by 'guix pull'; return it the build procedure. +build + +;; Local Variables: +;; eval: (put 'with-load-path 'scheme-indent-function 1) +;; End: + +;;; build-self.scm ends here diff --git a/guix/build/pull.scm b/guix/build/pull.scm index 841787f0bb..281be23aa8 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -99,76 +99,64 @@ (define (wait-for-one-process) (lambda () (loop lst running completed))))))))) -(define* (build-guix out tarball - #:key tar gzip gcrypt +(define* (build-guix out source + #:key gcrypt (debug-port (%make-void-port "w"))) - "Build and install Guix in directory OUT using source from TARBALL. Write -any debugging output to DEBUG-PORT." + "Build and install Guix in directory OUT using SOURCE, a directory +containing the source code. Write any debugging output to DEBUG-PORT." (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF) - (setenv "PATH" (string-append tar "/bin:" gzip "/bin")) - - (format debug-port "extracting '~a'...~%" tarball) - (system* "tar" "xf" tarball) - - (match (scandir "." (lambda (name) - (and (not (member name '("." ".."))) - (file-is-directory? name)))) - ((dir) - (chdir dir)) - (x - (error "tarball did not produce a single source directory" x))) - - (format #t "copying and compiling to '~a'...~%" out) - - ;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm. - (copy-recursively "guix" (string-append out "/guix") - #:log debug-port) - (copy-recursively "gnu" (string-append out "/gnu") - #:log debug-port) - (copy-file "guix.scm" (string-append out "/guix.scm")) - (copy-file "gnu.scm" (string-append out "/gnu.scm")) - - ;; Add a fake (guix config) module to allow the other modules to be - ;; compiled. The user's (guix config) is the one that will be used. - (copy-file "guix/config.scm.in" - (string-append out "/guix/config.scm")) - (substitute* (string-append out "/guix/config.scm") - (("@LIBGCRYPT@") - (string-append gcrypt "/lib/libgcrypt"))) - - ;; Augment the search path so Scheme code can be compiled. - (set! %load-path (cons out %load-path)) - (set! %load-compiled-path (cons out %load-compiled-path)) - - ;; Compile the .scm files. Do that in independent processes, à la - ;; 'make -j', to work around (FIXME). - ;; This ensures correctness, but is overly conservative and slow. - ;; The solution initially implemented (and described in the bug - ;; above) was slightly faster but consumed memory proportional to the - ;; number of modules, which quickly became unacceptable. - (p-for-each (lambda (file) - (let ((go (string-append (string-drop-right file 4) - ".go"))) - (format debug-port "~%compiling '~a'...~%" file) - (parameterize ((current-warning-port debug-port)) - (compile-file file - #:output-file go - #:opts - %auto-compilation-options)))) - - (filter (cut string-suffix? ".scm" <>) - - ;; Build guix/*.scm before gnu/*.scm to speed - ;; things up. - (sort (find-files out "\\.scm") - (let ((guix (string-append out "/guix")) - (gnu (string-append out "/gnu"))) - (lambda (a b) - (or (and (string-prefix? guix a) - (string-prefix? gnu b)) - (string (FIXME). + ;; This ensures correctness, but is overly conservative and slow. + ;; The solution initially implemented (and described in the bug + ;; above) was slightly faster but consumed memory proportional to the + ;; number of modules, which quickly became unacceptable. + (p-for-each (lambda (file) + (let ((go (string-append (string-drop-right file 4) + ".go"))) + (format debug-port "~%compiling '~a'...~%" file) + (parameterize ((current-warning-port debug-port)) + (compile-file file + #:output-file go + #:opts + %auto-compilation-options)))) + + (filter (cut string-suffix? ".scm" <>) + + ;; Build guix/*.scm before gnu/*.scm to speed + ;; things up. + (sort (find-files out "\\.scm") + (let ((guix (string-append out "/guix")) + (gnu (string-append out "/gnu"))) + (lambda (a b) + (or (and (string-prefix? guix a) + (string-prefix? gnu b)) + (stringderivation "guix-latest" builder - #:modules '((guix build pull) - (guix build utils)))) +(define-syntax-rule (with-PATH value body ...) + (with-environment-variable "PATH" value body ...)) ;;; @@ -118,10 +111,82 @@ (define what-to-build (define indirect-root-added (store-lift add-indirect-root)) +(define (temporary-directory) + "Make a temporary directory and return its name." + (let ((name (tmpnam))) + (mkdir name) + (chmod name #o700) + name)) + +(define (first-directory directory) + "Return a the name of the first file found under DIRECTORY." + (match (scandir directory + (lambda (name) + (and (not (member name '("." ".."))) + (file-is-directory? name)))) + ((directory) + directory) + (x + (raise (condition + (&message + (message "tarball did not produce a single source directory"))))))) + +(define (interned-then-deleted directory name) + "Add DIRECTORY to the store under NAME, and delete it. Return the resulting +store file name." + (mlet %store-monad ((result (interned-file directory name + #:recursive? #t))) + (delete-file-recursively directory) + (return result))) + +(define (unpack tarball) + "Return the name of the directory where TARBALL has been unpacked." + (mlet* %store-monad ((format -> (lift format %store-monad)) + (tar (package->derivation tar)) + (gzip (package->derivation gzip))) + (mbegin %store-monad + (what-to-build (list tar gzip)) + (built-derivations (list tar gzip)) + (format #t (_ "unpacking '~a'...~%") tarball) + + (let ((source (temporary-directory))) + (with-directory-excursion source + (with-PATH (string-append (derivation->output-path gzip) "/bin") + (unless (zero? (system* (string-append (derivation->output-path tar) + "/bin/tar") + "xf" tarball)) + (raise (condition + (&message (message "failed to unpack source code")))))) + + (interned-then-deleted (string-append source "/" + (first-directory source)) + "guix-source")))))) + +(define %self-build-file + ;; The file containing code to build Guix. This serves the same purpose as + ;; a makefile, and, similarly, is intended to always keep this name. + "build-aux/build-self.scm") + +(define* (build-from-source tarball #:key verbose?) + "Return a derivation to build Guix from TARBALL, using the self-build script +contained therein." + ;; Running the self-build script makes it easier to update the build + ;; procedure: the self-build script of the Guix-to-be-installed contains the + ;; right dependencies, build procedure, etc., which the Guix-in-use may not + ;; be know. + (mlet* %store-monad ((source (unpack tarball)) + (script -> (string-append source "/" + %self-build-file)) + (build -> (primitive-load script))) + ;; BUILD must be a monadic procedure of at least one argument: the source + ;; tree. + (build source #:verbose? verbose?))) + (define* (build-and-install tarball config-dir #:key verbose?) "Build the tool from TARBALL, and install it in CONFIG-DIR." - (mlet* %store-monad ((source (unpack tarball #:verbose? verbose?)) + (mlet* %store-monad ((source (build-from-source tarball + #:verbose? verbose?)) (source-dir -> (derivation->output-path source)) (to-do? (what-to-build (list source)))) (if to-do? @@ -165,3 +230,10 @@ (define (parse-options) (run-with-store store (build-and-install tarball (config-directory) #:verbose? (assoc-ref opts 'verbose?)))))))) + +;; Local Variables: +;; eval: (put 'with-PATH 'scheme-indent-function 1) +;; eval: (put 'with-temporary-directory 'scheme-indent-function 1) +;; End: + +;;; pull.scm ends here -- cgit v1.2.3