Merge branch 'master' into core-updates

4 files changed, 173 insertions, 10 deletions

diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 485150ea51..7852a6ab26 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -22,6 +22,7 @@
             file-system
             file-system?
             file-system-device
+            file-system-title
             file-system-mount-point
             file-system-type
             file-system-needed-for-boot?
@@ -42,6 +43,8 @@
   make-file-system
   file-system?
   (device           file-system-device)           ; string
+  (title            file-system-title             ; 'device | 'label | 'uuid
+                    (default 'device))
   (mount-point      file-system-mount-point)      ; string
   (type             file-system-type)             ; string
   (flags            file-system-flags             ; list of symbols
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
new file mode 100644
index 0000000000..06f8a3f058
--- /dev/null
+++ b/gnu/system/install.scm
@@ -0,0 +1,147 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 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 (gnu system install)
+  #:use-module (gnu)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages package-management)
+  #:use-module (gnu packages disk)
+  #:use-module (gnu packages texinfo)
+  #:export (installation-os))
+
+;;; Commentary:
+;;;
+;;; This module provides an 'operating-system' definition for use on images
+;;; for USB sticks etc., for the installation of the GNU system.
+;;;
+;;; Code:
+
+(define (log-to-info)
+  "Return a script that spawns the Info reader on the right section of the
+manual."
+  (gexp->script "log-to-info"
+                #~(execl (string-append #$texinfo-4 "/bin/info") "info"
+                         "-d" "/run/current-system/profile/share/info"
+                         "-f" (string-append #$guix "/share/info/guix.info")
+                         "-n" "System Configuration")))
+
+(define (installation-services)
+  "Return the list services for the installation image."
+  (let ((motd (text-file "motd" "
+Welcome to the installation of the GNU operating system!
+
+There is NO WARRANTY, to the extent permitted by law.  In particular, you may
+LOSE ALL YOUR DATA as a side effect of the installation process.  Furthermore,
+it is alpha software, so it may BREAK IN UNEXPECTED WAYS.
+
+You have been warned.  Thanks for being so brave.
+")))
+    (define (normal-tty tty)
+      (mingetty-service tty
+                        #:motd motd
+                        #:auto-login "root"
+                        #:login-pause? #t))
+
+    (list (mingetty-service "tty1"
+                            #:motd motd
+                            #:auto-login "root")
+
+          ;; Documentation.
+          (mingetty-service "tty2"
+                            #:motd motd
+                            #:auto-login "guest"
+                            #:login-program (log-to-info))
+
+          ;; A bunch of 'root' ttys.
+          (normal-tty "tty3")
+          (normal-tty "tty4")
+          (normal-tty "tty5")
+          (normal-tty "tty6")
+
+          ;; The usual services.
+          (syslog-service)
+
+          ;; The build daemon.  Register the hydra.gnu.org key as trusted.
+          ;; This allows the installation process to use substitutes by
+          ;; default.
+          (guix-service #:authorize-hydra-key? #t)
+
+          (nscd-service))))
+
+(define %issue
+  ;; Greeting.
+  "
+This is an installation image of the GNU system.  Welcome.
+
+Use Alt-F2 for documentation.
+")
+
+(define installation-os
+  ;; The operating system used on installation images for USB sticks etc.
+  (operating-system
+    (host-name "gnu")
+    (timezone "Europe/Paris")
+    (locale "en_US.UTF-8")
+    (bootloader (grub-configuration
+                 (device "/dev/sda")))
+    (file-systems
+     ;; Note: the disk image build code overrides this root file system with
+     ;; the appropriate one.
+     (list (file-system
+             (mount-point "/")
+             (device "gnu-disk-image")
+             (type "ext4"))))
+
+    (users (list (user-account
+                  (name "guest")
+                  (group "wheel")
+                  (password "")
+                  (comment "Guest of GNU")
+                  (home-directory "/home/guest"))))
+    (groups (list (user-group (name "root") (id 0))
+                  (user-group
+                   (name "wheel")
+                   (id 1)
+                   (members '("guest")))          ; allow 'guest' to use sudo
+                  (user-group
+                   (name "users")
+                   (id 100)
+                   (members '("guest")))))
+
+    (issue %issue)
+
+    (services (installation-services))
+
+    ;; We don't need setuid programs so pass the empty list so we don't pull
+    ;; additional programs here.
+    (setuid-programs '())
+
+    (pam-services
+     ;; Explicitly allow for empty passwords.
+     (base-pam-services #:allow-empty-passwords? #t))
+
+    (packages (cons* texinfo-4                ; for the standalone Info reader
+                     parted fdisk ddrescue
+                     %base-packages))))
+
+;; Return it here so 'guix system' can consume it directly.
+installation-os
+
+;;; install.scm ends here
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index b80ff10f1e..17fec4f7f4 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -198,8 +198,8 @@ a list of Guile module names to be embedded in the initrd."
   "Return a list corresponding to file-system FS that can be passed to the
 initrd code."
   (match fs
-    (($ <file-system> device mount-point type flags options _ check?)
-     (list device mount-point type flags options check?))))
+    (($ <file-system> device title mount-point type flags options _ check?)
+     (list device title mount-point type flags options check?))))
 
 (define* (qemu-initrd file-systems
                       #:key
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index a15c4c358b..4e7c439894 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -29,7 +29,7 @@
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
   #:use-module (gnu packages qemu)
-  #:use-module (gnu packages parted)
+  #:use-module (gnu packages disk)
   #:use-module (gnu packages zile)
   #:use-module (gnu packages grub)
   #:use-module (gnu packages linux)
@@ -196,15 +196,17 @@ made available under the /xchg CIFS share."
                      (disk-image-size (* 100 (expt 2 20)))
                      (disk-image-format "qcow2")
                      (file-system-type "ext4")
+                     file-system-label
                      grub-configuration
                      (register-closures? #t)
                      (inputs '())
                      copy-inputs?)
   "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
-'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.  The
-returned image is a full disk image, with a GRUB installation that uses
-GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the
-name of a file in the VM.)
+'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
+Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
+partition.  The returned image is a full disk image, with a GRUB installation
+that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION
+must be the name of a file in the VM.)
 
 INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
@@ -243,7 +245,8 @@ the image."
                                   #:copy-closures? #$copy-inputs?
                                   #:register-closures? #$register-closures?
                                   #:disk-image-size #$disk-image-size
-                                  #:file-system-type #$file-system-type)
+                                  #:file-system-type #$file-system-type
+                                  #:file-system-label #$file-system-label)
             (reboot))))
     #:system system
     #:make-disk-image? #t
@@ -258,6 +261,7 @@ the image."
 
 (define* (system-disk-image os
                             #:key
+                            (name "disk-image")
                             (file-system-type "ext4")
                             (disk-image-size (* 900 (expt 2 20)))
                             (volatile? #t))
@@ -265,6 +269,12 @@ the image."
 system described by OS.  Said image can be copied on a USB stick as is.  When
 VOLATILE? is true, the root file system is made volatile; this is useful
 to USB sticks meant to be read-only."
+  (define root-label
+    ;; 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.)
+    "gnu-disk-image")
+
   (define file-systems-to-keep
     (remove (lambda (fs)
               (string=? (file-system-mount-point fs) "/"))
@@ -280,16 +290,19 @@ to USB sticks meant to be read-only."
               ;; Force our own root file system.
               (file-systems (cons (file-system
                                     (mount-point "/")
-                                    (device "/dev/sda1")
+                                    (device root-label)
+                                    (title 'label)
                                     (type file-system-type))
                                   file-systems-to-keep)))))
 
     (mlet* %store-monad ((os-drv   (operating-system-derivation os))
                          (grub.cfg (operating-system-grub.cfg os)))
-      (qemu-image #:grub-configuration grub.cfg
+      (qemu-image #:name name
+                  #:grub-configuration grub.cfg
                   #:disk-image-size disk-image-size
                   #:disk-image-format "raw"
                   #:file-system-type file-system-type
+                  #:file-system-label root-label
                   #:copy-inputs? #t
                   #:register-closures? #t
                   #:inputs `(("system" ,os-drv)