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.

2 files changed, 151 insertions, 91 deletions

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