Merge branch 'master' into core-updates

4 files changed, 96 insertions, 46 deletions

diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index f9aa7f6733..6837385daf 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -306,7 +306,7 @@ Use Alt-F2 for documentation.
      ;; the appropriate one.
      (cons* (file-system
               (mount-point "/")
-              (device "GuixSD")
+              (device "GuixSD_image")
               (title 'label)
               (type "ext4"))
 
diff --git a/gnu/system/locale.scm b/gnu/system/locale.scm
index 3bb9f950a8..75cb855b59 100644
--- a/gnu/system/locale.scm
+++ b/gnu/system/locale.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,10 +19,8 @@
 (define-module (gnu system locale)
   #:use-module (guix gexp)
   #:use-module (guix store)
-  #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix packages)
-  #:use-module (guix utils)
   #:use-module (gnu packages base)
   #:use-module (gnu packages compression)
   #:use-module (srfi srfi-26)
@@ -85,24 +83,15 @@ or #f on failure."
 (define* (localedef-command locale
                             #:key (libc (canonical-package glibc)))
   "Return a gexp that runs 'localedef' from LIBC to build LOCALE."
-  (define (maybe-version-directory)
-    ;; XXX: For libc prior to 2.22, GuixSD did not store locale data in a
-    ;; version-specific sub-directory.  Check whether this is the case.
-    ;; TODO: Remove this hack once libc 2.21 is buried.
-    (let ((version (package-version libc)))
-      (if (version>=? version "2.22")
-          (list version "/")
-          '())))
-
   #~(begin
       (format #t "building locale '~a'...~%"
               #$(locale-definition-name locale))
-      (zero? (system* (string-append #$libc "/bin/localedef")
+      (zero? (system* (string-append #+libc "/bin/localedef")
                       "--no-archive" "--prefix" #$output
                       "-i" #$(locale-definition-source locale)
                       "-f" #$(locale-definition-charset locale)
                       (string-append #$output "/"
-                                     #$@(maybe-version-directory)
+                                     #$(package-version libc) "/"
                                      #$(locale-definition-name locale))))))
 
 (define* (single-locale-directory locales
@@ -119,12 +108,7 @@ of LIBC."
     #~(begin
         (mkdir #$output)
 
-        ;; XXX: For libcs < 2.22, locale data is stored in the top-level
-        ;; directory.
-        ;; TODO: Remove this hack once libc 2.21 is buried.
-        #$(if (version>=? version "2.22")
-              #~(mkdir (string-append #$output "/" #$version))
-              #~(symlink "." (string-append #$output "/" #$version)))
+        (mkdir (string-append #$output "/" #$version))
 
         ;; 'localedef' executes 'gzip' to access compressed locale sources.
         (setenv "PATH" (string-append #$gzip "/bin"))
@@ -133,8 +117,7 @@ of LIBC."
          (and #$@(map (cut localedef-command <> #:libc libc)
                       locales)))))
 
-  (gexp->derivation (string-append "locale-" version) build
-                    #:local-build? #t))
+  (computed-file (string-append "locale-" version) build))
 
 (define* (locale-directory locales
                            #:key (libcs %default-locale-libcs))
@@ -148,18 +131,16 @@ data format changes between libc versions."
     ((libc)
      (single-locale-directory locales #:libc libc))
     ((libcs ..1)
-     (mlet %store-monad ((dirs (mapm %store-monad
-                                     (lambda (libc)
-                                       (single-locale-directory locales
-                                                                #:libc libc))
-                                     libcs)))
-       (gexp->derivation "locale-multiple-versions"
-                         (with-imported-modules '((guix build union))
-                           #~(begin
-                               (use-modules (guix build union))
-                               (union-build #$output (list #$@dirs))))
-                         #:local-build? #t
-                         #:substitutable? #f)))))
+     (let ((dirs (map (lambda (libc)
+                        (single-locale-directory locales #:libc libc))
+                      libcs)))
+       (computed-file "locale-multiple-versions"
+                      (with-imported-modules '((guix build union))
+                        #~(begin
+                            (use-modules (guix build union))
+                            (union-build #$output (list #$@dirs))))
+                      #:options '(#:local-build? #t
+                                  #:substitutable? #f))))))
 
 (define %default-locale-libcs
   ;; The libcs for which we build locales by default.
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index b30ef8e390..712e6df8d8 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -143,7 +143,7 @@
     (with-imported-modules '((guix build utils))
       #~(begin
           (use-modules (guix build utils))
-          (copy-file (car (find-files #$guile-wm "wm-init-sample.scm"))
+          (copy-file (car (find-files #+guile-wm "wm-init-sample.scm"))
                      #$output))))
 
   (let ((profile (plain-file "bash_profile" "\
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 66a2448ceb..90d29b0783 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -39,7 +39,7 @@
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
-  #:use-module (gnu packages qemu)
+  #:use-module (gnu packages virtualization)
   #:use-module (gnu packages disk)
   #:use-module (gnu packages zile)
   #:use-module (gnu packages linux)
@@ -68,7 +68,10 @@
 
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
-            system-disk-image))
+            system-disk-image
+
+            virtual-machine
+            virtual-machine?))
 
 
 ;;; Commentary:
@@ -105,16 +108,19 @@
                                              (guile-for-build
                                               (%guile-for-build))
 
+                                             (single-file-output? #f)
                                              (make-disk-image? #f)
                                              (references-graphs #f)
                                              (memory-size 256)
                                              (disk-image-format "qcow2")
                                              (disk-image-size 'guess))
   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
-derivation).  In the virtual machine, EXP has access to all its inputs from the
-store; it should put its output files in the `/xchg' directory, which is
-copied to the derivation's output when the VM terminates.  The virtual machine
-runs with MEMORY-SIZE MiB of memory.
+derivation).  The virtual machine runs with MEMORY-SIZE MiB of memory.  In the
+virtual machine, EXP has access to all its inputs from the store; it should
+put its output file(s) in the '/xchg' directory.
+
+If SINGLE-FILE-OUTPUT? is true, copy a single file from '/xchg' to OUTPUT.
+Otherwise, copy the contents of /xchg to a new directory OUTPUT.
 
 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
 DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
@@ -164,6 +170,7 @@ made available under the /xchg CIFS share."
                                 #:linux linux #:initrd initrd
                                 #:memory-size #$memory-size
                                 #:make-disk-image? #$make-disk-image?
+                                #:single-file-output? #$single-file-output?
                                 #:disk-image-format #$disk-image-format
                                 #:disk-image-size size
                                 #:references-graphs graphs)))))
@@ -219,6 +226,7 @@ INPUTS is a list of inputs (as for packages)."
            (reboot))))
    #:system system
    #:make-disk-image? #f
+   #:single-file-output? #t
    #:references-graphs inputs))
 
 (define* (qemu-image #:key
@@ -345,7 +353,7 @@ to USB sticks meant to be read-only."
     ;; Volume name of the root file system.  Since we don't know which device
     ;; will hold it, we use the volume name to find it (using the UUID would
     ;; be even better, but somewhat less convenient.)
-    (normalize-label "GuixSD"))
+    (normalize-label "GuixSD_image"))
 
   (define file-systems-to-keep
     (remove (lambda (fs)
@@ -576,7 +584,8 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
                                                 full-boot?
                                                 (disk-image-size
                                                  (* (if full-boot? 500 70)
-                                                    (expt 2 20))))
+                                                    (expt 2 20)))
+                                                (options '()))
   "Return a derivation that builds a script to run a virtual machine image of
 OS that shares its store with the host.  The virtual machine runs with
 MEMORY-SIZE MiB of memory.
@@ -609,7 +618,8 @@ it is mostly useful when FULL-BOOT?  is true."
               #$@(common-qemu-options image
                                       (map file-system-mapping-source
                                            (cons %store-mapping mappings)))
-              "-m " (number->string #$memory-size)))
+              "-m " (number->string #$memory-size)
+              #$@options))
 
     (define builder
       #~(call-with-output-file #$output
@@ -621,4 +631,63 @@ it is mostly useful when FULL-BOOT?  is true."
 
     (gexp->derivation "run-vm.sh" builder)))
 
+
+;;;
+;;; High-level abstraction.
+;;;
+
+(define-record-type* <virtual-machine> %virtual-machine
+  make-virtual-machine
+  virtual-machine?
+  (operating-system virtual-machine-operating-system) ;<operating-system>
+  (qemu             virtual-machine-qemu              ;<package>
+                    (default qemu))
+  (graphic?         virtual-machine-graphic?      ;Boolean
+                    (default #f))
+  (memory-size      virtual-machine-memory-size   ;integer (MiB)
+                    (default 256))
+  (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
+                    (default '())))
+
+(define-syntax virtual-machine
+  (syntax-rules ()
+    "Declare a virtual machine running the specified OS, with the given
+options."
+    ((_ os)                                       ;shortcut
+     (%virtual-machine (operating-system os)))
+    ((_ fields ...)
+     (%virtual-machine fields ...))))
+
+(define (port-forwardings->qemu-options forwardings)
+  "Return the QEMU option for the given port FORWARDINGS as a string, where
+FORWARDINGS is a list of host-port/guest-port pairs."
+  (string-join
+   (map (match-lambda
+          ((host-port . guest-port)
+           (string-append "hostfwd=tcp::"
+                          (number->string host-port)
+                          "-:" (number->string guest-port))))
+        forwardings)
+   ","))
+
+(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
+                                                system target)
+  ;; XXX: SYSTEM and TARGET are ignored.
+  (match vm
+    (($ <virtual-machine> os qemu graphic? memory-size ())
+     (system-qemu-image/shared-store-script os
+                                            #:qemu qemu
+                                            #:graphic? graphic?
+                                            #:memory-size memory-size))
+    (($ <virtual-machine> os qemu graphic? memory-size forwardings)
+     (let ((options
+            `("-net" ,(string-append
+                       "user,"
+                       (port-forwardings->qemu-options forwardings)))))
+       (system-qemu-image/shared-store-script os
+                                              #:qemu qemu
+                                              #:graphic? graphic?
+                                              #:memory-size memory-size
+                                              #:options options)))))
+
 ;;; vm.scm ends here