nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

pull: Use the build procedure provided by the newly-downloaded Guix. 

Fixes <http://bugs.gnu.org/18534>.

* 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.
This commit is contained in:
Ludovic Courtès 2014-11-09 22:32:21 +01:00
parent 4684f301d5
commit f81ac34dd9
4 changed files with 244 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -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 \

98
build-aux/build-self.scm Normal file
View File

@ -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

108
guix/build/pull.scm
View File

@ -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"))
(with-directory-excursion source
(format #t "copying and compiling to '~a'...~%" out)
(format debug-port "extracting '~a'...~%" tarball)
(system* "tar" "xf" tarball)
;; 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"))
(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)))
;; 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")))
(format #t "copying and compiling to '~a'...~%" out)
;; 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))
;; 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"))
;; 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))))
;; 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")))
(filter (cut string-suffix? ".scm" <>)
;; 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)))))))
;; 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"))

122
guix/scripts/pull.scm
View File

@ -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