M Makefile.am => Makefile.am +1 -0
@@ 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 \
A build-aux/build-self.scm => build-aux/build-self.scm +98 -0
@@ 0,0 1,98 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 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/>.
+
+(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
M guix/build/pull.scm => guix/build/pull.scm +54 -66
@@ 99,76 99,64 @@ the continuation. Raise an error if one of the processes exit with non-zero."
(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 <http://bugs.gnu.org/15602> (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<? a b)))))))
+ (with-directory-excursion source
+ (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 <http://bugs.gnu.org/15602> (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<? a b))))))))
;; Remove the "fake" (guix config).
(delete-file (string-append out "/guix/config.scm"))
M guix/scripts/pull.scm => guix/scripts/pull.scm +97 -25
@@ 25,6 25,8 @@
#:use-module (guix download)
#:use-module (guix gexp)
#:use-module (guix monads)
+ #:use-module ((guix build utils)
+ #:select (with-directory-excursion delete-file-recursively))
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module ((gnu packages bootstrap)
@@ 32,7 34,11 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages gnupg)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
#:export (guix-pull))
(define %snapshot-url
@@ 40,31 46,18 @@
"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
)
-(define* (unpack tarball #:key verbose?)
- "Return a derivation that unpacks TARBALL into STORE and compiles Scheme
-files."
- (define builder
- #~(begin
- (use-modules (guix build pull))
+(define-syntax-rule (with-environment-variable variable value body ...)
+ (let ((original (getenv variable)))
+ (dynamic-wind
+ (lambda ()
+ (setenv variable value))
+ (lambda ()
+ body ...)
+ (lambda ()
+ (setenv variable original)))))
- (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 #$tarball
-
- ;; XXX: This is not perfect, enabling VERBOSE? means
- ;; building a different derivation.
- #:debug-port (if #$verbose?
- (current-error-port)
- (%make-void-port "w"))
- #:tar #$tar
- #:gzip #$gzip
- #:gcrypt #$libgcrypt)))
-
- (gexp->derivation "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 @@ Download and deploy the latest version of Guix.\n"))
(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 @@ Download and deploy the latest version of Guix.\n"))
(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