pull: Move build code to (guix build pull).

* guix/build/pull.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/pull.scm (unpack): Use it.

3 files changed, 158 insertions, 123 deletions

diff --git a/Makefile.am b/Makefile.am
index 13088ff525..eb278a76e9 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -60,6 +60,7 @@ MODULES =					\
   guix/build/python-build-system.scm		\
   guix/build/utils.scm				\
   guix/build/union.scm				\
+  guix/build/pull.scm				\
   guix/build/rpath.scm				\
   guix/packages.scm				\
   guix/snix.scm					\
diff --git a/guix/build/pull.scm b/guix/build/pull.scm
new file mode 100644
index 0000000000..4bad88fe42
--- /dev/null
+++ b/guix/build/pull.scm
@@ -0,0 +1,148 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 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 (guix build pull)
+  #:use-module (guix build utils)
+  #:use-module (system base compile)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:export (build-guix))
+
+;;; Commentary:
+;;;
+;;; Helpers for the 'guix pull' command to unpack and build Guix.
+;;;
+;;; Code:
+
+(define (call-with-process thunk)
+  "Run THUNK in a separate process that will return 0 if THUNK terminates
+normally, and 1 if an exception is raised."
+  (match (primitive-fork)
+    (0
+     (catch #t
+       (lambda ()
+         (thunk)
+         (primitive-exit 0))
+       (lambda (key . args)
+         (print-exception (current-error-port) #f key args)
+         (primitive-exit 1))))
+    (pid
+     #t)))
+
+(define* (p-for-each proc lst
+                     #:optional (max-processes (current-processor-count)))
+  "Invoke PROC for each element of LST in a separate process, using up to
+MAX-PROCESSES processes in parallel.  Raise an error if one of the processes
+exit with non-zero."
+  (define (wait-for-one-process)
+    (match (waitpid WAIT_ANY)
+      ((_ . status)
+       (unless (zero? (status:exit-val status))
+         (error "process failed" proc status)))))
+
+  (let loop ((lst   lst)
+             (running 0))
+    (match lst
+      (()
+       (or (zero? running)
+           (begin
+             (wait-for-one-process)
+             (loop lst (- running 1)))))
+      ((head . tail)
+       (if (< running max-processes)
+           (begin
+             (call-with-process (cut proc head))
+             (loop tail (+ running 1)))
+           (begin
+             (wait-for-one-process)
+             (loop lst (- running 1))))))))
+
+(define* (build-guix out tarball
+                     #:key tar gzip gcrypt)
+  "Build and install Guix in directory OUT using source from TARBALL."
+  (setvbuf (current-output-port) _IOLBF)
+  (setvbuf (current-error-port) _IOLBF)
+
+  (setenv "PATH" (string-append tar "/bin:" gzip "/bin"))
+
+  (system* "tar" "xvf" 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 Guix to `~a'...~%" out)
+
+  ;; Copy everything under guix/ and gnu/ plus guix.scm.
+  (copy-recursively "guix" (string-append out "/guix"))
+  (copy-recursively "gnu" (string-append out "/gnu"))
+  (copy-file "guix.scm" (string-append out "/guix.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 (current-error-port)
+                          "compiling '~a'...~%" file)
+                  (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"))
+  (delete-file (string-append out "/guix/config.go"))
+
+  #t)
+
+;;; pull.scm ends here
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 11f5cc1493..00bea1707d 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -41,129 +41,14 @@
   "Return a derivation that unpacks TARBALL into STORE and compiles Scheme
 files."
   (define builder
-    `(begin
-       (use-modules (guix build utils)
-                    (system base compile)
-                    (ice-9 ftw)
-                    (ice-9 match)
-                    (srfi srfi-1)
-                    (srfi srfi-11)
-                    (srfi srfi-26))
+    '(begin
+       (use-modules (guix build pull))
 
-       (setvbuf (current-output-port) _IOLBF)
-       (setvbuf (current-error-port) _IOLBF)
-
-       (let ((out     (assoc-ref %outputs "out"))
-             (tar     (assoc-ref %build-inputs "tar"))
-             (gzip    (assoc-ref %build-inputs "gzip"))
-             (gcrypt  (assoc-ref %build-inputs "gcrypt"))
-             (tarball (assoc-ref %build-inputs "tarball")))
-
-         (define (call-with-process thunk)
-           ;; Run THUNK in a separate process that will return 0 if THUNK
-           ;; terminates normally, and 1 if an exception is raised.
-           (match (primitive-fork)
-             (0
-              (catch #t
-                (lambda ()
-                  (thunk)
-                  (primitive-exit 0))
-                (lambda (key . args)
-                  (print-exception (current-error-port) #f key args)
-                  (primitive-exit 1))))
-             (pid
-              #t)))
-
-         (define (p-for-each proc lst)
-           ;; Invoke PROC for each element of LST in a separate process.
-           ;; Raise an error if one of the processes exit with non-zero.
-           (define (wait-for-one-process)
-             (match (waitpid WAIT_ANY)
-               ((_ . status)
-                (unless (zero? (status:exit-val status))
-                  (error "process failed" proc status)))))
-
-           (define max-processes
-             (current-processor-count))
-
-           (let loop ((lst   lst)
-                      (running 0))
-             (match lst
-               (()
-                (or (zero? running)
-                    (begin
-                      (wait-for-one-process)
-                      (loop lst (- running 1)))))
-               ((head . tail)
-                (if (< running max-processes)
-                    (begin
-                      (call-with-process (cut proc head))
-                      (loop tail (+ running 1)))
-                    (begin
-                      (wait-for-one-process)
-                      (loop lst (- running 1))))))))
-
-         (setenv "PATH" (string-append tar "/bin:" gzip "/bin"))
-
-         (system* "tar" "xvf" 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 Guix to `~a'...~%" out)
-
-         ;; Copy everything under guix/ and gnu/ plus guix.scm.
-         (copy-recursively "guix" (string-append out "/guix"))
-         (copy-recursively "gnu" (string-append out "/gnu"))
-         (copy-file "guix.scm" (string-append out "/guix.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 (current-error-port)
-                                 "compiling '~a'...~%" file)
-                         (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"))
-         (delete-file (string-append out "/guix/config.go")))))
+       (build-guix (assoc-ref %outputs "out")
+                   (assoc-ref %build-inputs "tarball")
+                   #:tar (assoc-ref %build-inputs "tar")
+                   #:gzip (assoc-ref %build-inputs "gzip")
+                   #:gcrypt (assoc-ref %build-inputs "gcrypt"))))
 
   (build-expression->derivation store "guix-latest" builder
                                 #:inputs
@@ -172,7 +57,8 @@ files."
                                   ("gcrypt" ,(package-derivation store
                                                                  libgcrypt))
                                   ("tarball" ,tarball))
-                                #:modules '((guix build utils))))
+                                #:modules '((guix build pull)
+                                            (guix build utils))))
 
 
 ;;;