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.

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