summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-11-09 22:32:21 +0100
committerLudovic Courtès <ludo@gnu.org>2014-11-09 22:33:45 +0100
commitf81ac34dd9ab0f2ebaabf2cf382bd52d0d78396a (patch)
treef66eec8952dcbd4e09b346ea8132b75af011bd3d /guix/scripts
parent4684f301d5a7ff39a913c8f06507f67ec9b4a1cd (diff)
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.
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/pull.scm122
1 files changed, 97 insertions, 25 deletions
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 919ef2d467..16805bad3f 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -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