Merge remote-tracking branch 'origin/master' into staging

7 files changed, 238 insertions, 41 deletions

diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm
new file mode 100644
index 0000000000..bc4c0e3d5f
--- /dev/null
+++ b/guix/build/make-bootstrap.scm
@@ -0,0 +1,84 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Manolis Fragkiskos Ragkousis <manolis837@gmail.com>
+;;; Copyright © 2015 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 make-bootstrap)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (guix build utils)
+  #:export (make-stripped-libc))
+
+;; Commentary:
+;;
+;; This module provides facilities to build the bootstrap binaries.
+;;
+;; Code:
+
+(define (make-stripped-libc output libc kernel-headers)
+  "Copy to OUTPUT the subset of LIBC and KERNEL-HEADERS that is needed
+when producing a bootstrap libc."
+
+  (define (copy-mach-headers output kernel-headers)
+    (let* ((incdir (string-append output "/include")))
+      (copy-recursively (string-append libc "/include") incdir)
+
+      (copy-recursively (string-append kernel-headers "/include/mach")
+                        (string-append incdir "/mach"))
+      #t))
+  
+  (define (copy-linux-headers output kernel-headers)
+    (let* ((incdir (string-append output "/include")))
+      (copy-recursively (string-append libc "/include") incdir)
+
+      ;; Copy some of the Linux-Libre headers that glibc headers
+      ;; refer to.
+      (mkdir (string-append incdir "/linux"))
+      (for-each (lambda (file)
+                  (install-file (string-append kernel-headers "/include/linux/" file)
+                                (string-append incdir "/linux")))
+                '("limits.h" "errno.h" "socket.h" "kernel.h"
+                  "sysctl.h" "param.h" "ioctl.h" "types.h"
+                  "posix_types.h" "stddef.h"))
+
+      (copy-recursively (string-append kernel-headers "/include/asm")
+                        (string-append incdir "/asm"))
+      (copy-recursively (string-append kernel-headers "/include/asm-generic")
+                        (string-append incdir "/asm-generic"))
+      #t))
+
+  (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\
+util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|libc(rt|)_nonshared\\.a)$")
+
+  (setvbuf (current-output-port) _IOLBF)
+  (let* ((libdir (string-append output "/lib")))
+    (mkdir-p libdir)
+    (for-each (lambda (file)
+                (let ((target (string-append libdir "/"
+                                             (basename file))))
+                  (copy-file file target)
+                  (remove-store-references target)))
+              (find-files (string-append libc "/lib") %libc-object-files-rx))
+    #t)
+
+    (if (directory-exists? (string-append kernel-headers "/include/mach"))
+        (copy-mach-headers output kernel-headers)
+        (copy-linux-headers output kernel-headers)))
+
+
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 237a9638d3..ebff11664d 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -75,6 +75,10 @@
   (private-key     build-machine-private-key      ; file name
                    (default (user-openssh-private-key)))
   (host-key        build-machine-host-key)        ; string
+  (compression     build-machine-compression  ; string
+                   (default "zlib@openssh.com,zlib"))
+  (compression-level build-machine-compression-level ;integer
+                     (default 3))
   (daemon-socket   build-machine-daemon-socket    ; string
                    (default "/var/guix/daemon-socket/socket"))
   (parallel-builds build-machine-parallel-builds  ; number
@@ -169,14 +173,16 @@ private key from '~a': ~a")
         (session (make-session #:user (build-machine-user machine)
                                #:host (build-machine-name machine)
                                #:port (build-machine-port machine)
-                               #:timeout 5        ;seconds
+                               #:timeout 10       ;seconds
                                ;; #:log-verbosity 'protocol
                                #:identity (build-machine-private-key machine)
 
                                ;; We need lightweight compression when
                                ;; exchanging full archives.
-                               #:compression "zlib"
-                               #:compression-level 3)))
+                               #:compression
+                               (build-machine-compression machine)
+                               #:compression-level
+                               (build-machine-compression-level machine))))
     (match (connect! session)
       ('ok
        ;; Authenticate the server.  XXX: Guile-SSH 0.10.1 doesn't know about
@@ -384,7 +390,8 @@ MACHINE."
              ;; Use exit code 100 for a permanent build failure.  The daemon
              ;; interprets other non-zero codes as transient build failures.
              (primitive-exit 100)))
-    (build-derivations store (list drv)))
+    (parameterize ((current-build-output-port (build-log-port)))
+      (build-derivations store (list drv))))
 
   (retrieve-files outputs store)
   (format (current-error-port) "done with offloaded '~a'~%"
@@ -445,9 +452,11 @@ be read."
                                   (with-store store
                                     (remove (cut valid-path? store <>)
                                             ',files)))))
+           (count   (length missing))
            (port    (store-import-channel session)))
-      (format #t (_ "sending ~a store files to '~a'...~%")
-              (length missing) (session-get session 'host))
+      (format #t (N_ "sending ~a store item to '~a'...~%"
+                     "sending ~a store items to '~a'...~%" count)
+              count (session-get session 'host))
 
       ;; Send MISSING in topological order.
       (export-paths store missing port)
@@ -466,9 +475,11 @@ be read."
   "Retrieve FILES from SESSION's store, and import them."
   (let* ((session (channel-get-session (nix-server-socket remote)))
          (host    (session-get session 'host))
-         (port    (store-export-channel session files)))
-    (format #t (_ "retrieving ~a files from '~a'...~%")
-            (length files) host)
+         (port    (store-export-channel session files))
+         (count   (length files)))
+    (format #t (N_ "retrieving ~a store item from '~a'...~%"
+                   "retrieving ~a store items from '~a'...~%" count)
+            count host)
 
     ;; We cannot use the 'import-paths' RPC here because we already
     ;; hold the locks for FILES.
@@ -625,6 +636,86 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
 
 
 ;;;
+;;; Installation tests.
+;;;
+
+(define (assert-node-repl node name)
+  "Bail out if NODE is not running Guile."
+  (match (node-guile-version node)
+    (#f
+     (leave (_ "Guile could not be started on '~a'~%")
+            name))
+    ((? string? version)
+     ;; Note: The version string already contains the word "Guile".
+     (info (_ "'~a' is running ~a~%")
+           name (node-guile-version node)))))
+
+(define (assert-node-has-guix node name)
+  "Bail out if NODE lacks the (guix) module, or if its daemon is not running."
+  (match (node-eval node
+                    '(begin
+                       (use-modules (guix))
+                       (with-store store
+                         (add-text-to-store store "test"
+                                            "Hello, build machine!"))))
+    ((? string? str)
+     (info (_ "Guix is usable on '~a' (test returned ~s)~%")
+           name str))
+    (x
+     (leave (_ "failed to use Guix module on '~a' (test returned ~s)~%")
+            name x))))
+
+(define %random-state
+  (delay
+    (seed->random-state (logxor (getpid) (car (gettimeofday))))))
+
+(define (nonce)
+  (string-append (gethostname) "-"
+                 (number->string (random 1000000 (force %random-state)))))
+
+(define (assert-node-can-import node name daemon-socket)
+  "Bail out if NODE refuses to import our archives."
+  (let ((session (node-session node)))
+    (with-store store
+      (let* ((item   (add-text-to-store store "export-test" (nonce)))
+             (remote (connect-to-remote-daemon session daemon-socket)))
+        (send-files (list item) remote)
+        (if (valid-path? remote item)
+            (info (_ "'~a' successfully imported '~a'~%")
+                  name item)
+            (leave (_ "'~a' was not properly imported on '~a'~%")
+                   item name))))))
+
+(define (assert-node-can-export node name daemon-socket)
+  "Bail out if we cannot import signed archives from NODE."
+  (let* ((session (node-session node))
+         (remote  (connect-to-remote-daemon session daemon-socket))
+         (item    (add-text-to-store remote "import-test" (nonce)))
+         (port    (store-export-channel session (list item))))
+    (with-store store
+      (if (and (import-paths store port)
+               (valid-path? store item))
+          (info (_ "successfully imported '~a' from '~a'~%")
+                item name)
+          (leave (_ "failed to import '~a' from '~a'~%")
+                 item name)))))
+
+(define (check-machine-availability machine-file)
+  "Check that each machine in MACHINE-FILE is usable as a build machine."
+  (let ((machines (build-machines machine-file)))
+    (info (_ "testing ~a build machines defined in '~a'...~%")
+          (length machines) machine-file)
+    (let* ((names    (map build-machine-name machines))
+           (sockets  (map build-machine-daemon-socket machines))
+           (sessions (map open-ssh-session machines))
+           (nodes    (map make-node sessions)))
+      (for-each assert-node-repl nodes names)
+      (for-each assert-node-has-guix nodes names)
+      (for-each assert-node-can-import nodes names sockets)
+      (for-each assert-node-can-export nodes names sockets))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -673,6 +764,13 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
                    (else
                     (leave (_ "invalid request line: ~s~%") line)))
              (loop (read-line)))))))
+    (("test" rest ...)
+     (with-error-handling
+       (let ((file (match rest
+                     ((file) file)
+                     (()     %machine-file)
+                     (_      (leave (_ "wrong number of arguments~%"))))))
+         (check-machine-availability (or file %machine-file)))))
     (("--version")
      (show-version-and-exit "guix offload"))
     (("--help")
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 1b32f639ea..33a7b3bd42 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -365,6 +365,14 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
                            (response-headers response)
                            eq?)))
 
+(define (with-content-length response length)
+  "Return RESPONSE with a 'content-length' header set to LENGTH."
+  (set-field response (response-headers)
+             (alist-cons 'content-length length
+                         (alist-delete 'content-length
+                                       (response-headers response)
+                                       eq?))))
+
 (define-syntax-rule (swallow-EPIPE exp ...)
   "Swallow EPIPE errors raised by EXP..."
   (catch 'system-error
@@ -432,13 +440,8 @@ blocking."
             (call-with-input-file (utf8->string body)
               (lambda (input)
                 (let* ((size     (stat:size (stat input)))
-                       (headers  (alist-cons 'content-length size
-                                             (alist-delete 'content-length
-                                                           (response-headers response)
-                                                           eq?)))
-                       (response (write-response (set-field response
-                                                            (response-headers)
-                                                            headers)
+                       (response (write-response (with-content-length response
+                                                                      size)
                                                  client))
                        (output   (response-port response)))
                   (dump-port input output)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index e1ff544de0..805e4543ec 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -119,7 +119,7 @@
                   (show-version-and-exit "guix refresh")))))
 
 (define (show-help)
-  (display (_ "Usage: guix refresh [OPTION]... PACKAGE...
+  (display (_ "Usage: guix refresh [OPTION]... [PACKAGE]...
 Update package definitions to match the latest upstream version.
 
 When PACKAGE... is given, update only the specified packages.  Otherwise
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index bb373a6726..144a7fd377 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -326,7 +326,7 @@ it atomically, and then run OS's activation script."
     (let* ((system     (derivation->output-path drv))
            (number     (+ 1 (generation-number profile)))
            (generation (generation-file-name profile number)))
-      (symlink system generation)
+      (switch-symlinks generation system)
       (switch-symlinks profile generation)
 
       (format #t (_ "activating system...~%"))
diff --git a/guix/store.scm b/guix/store.scm
index a669011f3a..49549d0771 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -374,29 +374,36 @@ space on the file system so that the garbage collector can still operate,
 should the disk become full.  When CPU-AFFINITY is true, it must be an integer
 corresponding to an OS-level CPU number to which the daemon's worker process
 for this connection will be pinned.  Return a server object."
-  (let ((port (or port (open-unix-domain-socket file))))
-    (write-int %worker-magic-1 port)
-    (let ((r (read-int port)))
-      (and (eqv? r %worker-magic-2)
-           (let ((v (read-int port)))
-             (and (eqv? (protocol-major %protocol-version)
-                        (protocol-major v))
-                  (begin
-                    (write-int %protocol-version port)
-                    (when (>= (protocol-minor v) 14)
-                      (write-int (if cpu-affinity 1 0) port)
-                      (when cpu-affinity
-                        (write-int cpu-affinity port)))
-                    (when (>= (protocol-minor v) 11)
-                      (write-int (if reserve-space? 1 0) port))
-                    (let ((conn (%make-nix-server port
-                                                  (protocol-major v)
-                                                  (protocol-minor v)
-                                                  (make-hash-table 100)
-                                                  (make-hash-table 100))))
-                      (let loop ((done? (process-stderr conn)))
-                        (or done? (process-stderr conn)))
-                      conn))))))))
+  (guard (c ((nar-error? c)
+             ;; One of the 'write-' or 'read-' calls below failed, but this is
+             ;; really a connection error.
+             (raise (condition
+                     (&nix-connection-error (file (or port file))
+                                            (errno EPROTO))
+                     (&message (message "build daemon handshake failed"))))))
+    (let ((port (or port (open-unix-domain-socket file))))
+      (write-int %worker-magic-1 port)
+      (let ((r (read-int port)))
+        (and (eqv? r %worker-magic-2)
+             (let ((v (read-int port)))
+               (and (eqv? (protocol-major %protocol-version)
+                          (protocol-major v))
+                    (begin
+                      (write-int %protocol-version port)
+                      (when (>= (protocol-minor v) 14)
+                        (write-int (if cpu-affinity 1 0) port)
+                        (when cpu-affinity
+                          (write-int cpu-affinity port)))
+                      (when (>= (protocol-minor v) 11)
+                        (write-int (if reserve-space? 1 0) port))
+                      (let ((conn (%make-nix-server port
+                                                    (protocol-major v)
+                                                    (protocol-minor v)
+                                                    (make-hash-table 100)
+                                                    (make-hash-table 100))))
+                        (let loop ((done? (process-stderr conn)))
+                          (or done? (process-stderr conn)))
+                        conn)))))))))
 
 (define (close-connection server)
   "Close the connection to SERVER."
diff --git a/guix/utils.scm b/guix/utils.scm
index 65a2baa0a2..06f49daca8 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -70,6 +70,7 @@
             %current-system
             %current-target-system
             package-name->name+version
+            target-mingw?
             version-compare
             version>?
             version>=?
@@ -508,6 +509,10 @@ returned.  Both parts must not contain any '@'."
     (idx (values (substring spec 0 idx)
                  (substring spec (1+ idx))))))
 
+(define* (target-mingw? #:optional (target (%current-target-system)))
+  (and target
+       (string-suffix? "-mingw32" target)))
+
 (define version-compare
   (let ((strverscmp
          (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))