Merge branch 'master' into staging

6 files changed, 358 insertions, 40 deletions

diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl
index 459d241885..7e0c8fbee0 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -3,7 +3,7 @@
 
 (use-modules (gnu))
 (use-service-modules networking ssh)
-(use-package-modules admin)
+(use-package-modules screen ssh)
 
 (operating-system
   (host-name "komputilo")
@@ -40,7 +40,7 @@
                %base-user-accounts))
 
   ;; Globally-installed packages.
-  (packages (cons tcpdump %base-packages))
+  (packages (cons* screen openssh %base-packages))
 
   ;; Add services to the baseline: a DHCP client and
   ;; an SSH server.
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index bbac23fbdf..52f16676f5 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -20,9 +20,9 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (guix records)
-  #:use-module ((gnu build file-systems)
-                #:select (string->uuid uuid->string))
-  #:re-export (string->uuid
+  #:use-module (gnu system uuid)
+  #:re-export (uuid                               ;backward compatibility
+               string->uuid
                uuid->string)
   #:export (<file-system>
             file-system
@@ -44,7 +44,6 @@
             file-system->spec
             spec->file-system
             specification->file-system-mapping
-            uuid
 
             %fuse-control-file-system
             %binary-format-file-system
@@ -157,7 +156,10 @@ store--e.g., if FS is the root file system."
 initrd code."
   (match fs
     (($ <file-system> device title mount-point type flags options _ _ check?)
-     (list device title mount-point type flags options check?))))
+     (list (if (uuid? device)
+               (uuid-bytevector device)
+               device)
+           title mount-point type flags options check?))))
 
 (define (spec->file-system sexp)
   "Deserialize SEXP, a list, to the corresponding <file-system> object."
@@ -186,20 +188,6 @@ TARGET in the other system."
          (target spec)
          (writable? writable?)))))
 
-(define-syntax uuid
-  (lambda (s)
-    "Return the bytevector corresponding to the given UUID representation."
-    (syntax-case s ()
-      ((_ str)
-       (string? (syntax->datum #'str))
-       ;; A literal string: do the conversion at expansion time.
-       (let ((bv (string->uuid (syntax->datum #'str))))
-         (unless bv
-           (syntax-violation 'uuid "invalid UUID" s))
-         (datum->syntax #'str bv)))
-      ((_ str)
-       #'(string->uuid str)))))
-
 
 ;;;
 ;;; Common file systems.
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 7f6ffe9582..eb362f91a8 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -31,6 +31,7 @@
   #:use-module (gnu packages bash)
   #:use-module (gnu packages bootloaders)
   #:use-module (gnu packages linux)
+  #:use-module (gnu packages ssh)
   #:use-module (gnu packages cryptsetup)
   #:use-module (gnu packages package-management)
   #:use-module (gnu packages disk)
@@ -214,6 +215,9 @@ You have been warned.  Thanks for being so brave.
                                                 (auto-login "root")
                                                 (login-pause? #t))))
 
+    (define bare-bones-os
+      (load "examples/bare-bones.tmpl"))
+
     (list (mingetty-service (mingetty-configuration
                              (tty "tty1")
                              (auto-login "root")))
@@ -283,7 +287,11 @@ You have been warned.  Thanks for being so brave.
           ;; connections to this system to work.
           (service special-files-service-type
                    `(("/bin/sh" ,(file-append (canonical-package bash)
-                                              "/bin/sh")))))))
+                                              "/bin/sh"))))
+
+          ;; Keep a reference to BARE-BONES-OS to make sure it can be
+          ;; installed without downloading/building anything.
+          (service gc-root-service-type (list bare-bones-os)))))
 
 (define %issue
   ;; Greeting.
@@ -337,9 +345,9 @@ Use Alt-F2 for documentation.
     (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 '())
+    ;; We don't need setuid programs, except for 'passwd', which can be handy
+    ;; if one is to allow remote SSH login to the machine being installed.
+    (setuid-programs (list (file-append shadow "/bin/passwd")))
 
     (pam-services
      ;; Explicitly allow for empty passwords.
@@ -352,6 +360,7 @@ Use Alt-F2 for documentation.
                      mdadm
                      dosfstools         ;mkfs.fat, for the UEFI boot partition
                      btrfs-progs
+                     openssh    ;we already have sshd, having ssh/scp can help
                      wireless-tools iw wpa-supplicant-minimal iproute
                      ;; XXX: We used to have GNU fdisk here, but as of version
                      ;; 2.0.0a, that pulls Guile 1.8, which takes unreasonable
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 18b9f5b4b6..17cf6b7163 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.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>
 ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2017 Mark H Weaver <mhw@netris.org>
 ;;;
@@ -24,6 +24,7 @@
   #:use-module (guix modules)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu system uuid)
   #:autoload   (gnu packages cryptsetup) (cryptsetup-static)
   #:autoload   (gnu packages linux) (mdadm-static)
   #:use-module (srfi srfi-1)
@@ -99,7 +100,9 @@
 'cryptsetup'."
   (with-imported-modules (source-module-closure
                           '((gnu build file-systems)))
-    #~(let ((source #$source))
+    #~(let ((source #$(if (uuid? source)
+                          (uuid-bytevector source)
+                          source)))
         ;; XXX: 'use-modules' should be at the top level.
         (use-modules (rnrs bytevectors)           ;bytevector?
                      ((gnu build file-systems)
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
new file mode 100644
index 0000000000..1dd6a11339
--- /dev/null
+++ b/gnu/system/uuid.scm
@@ -0,0 +1,265 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.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 uuid)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 format)
+  #:export (uuid
+            uuid?
+            uuid-type
+            uuid-bytevector
+
+            bytevector->uuid
+
+            uuid->string
+            dce-uuid->string
+            string->uuid
+            string->dce-uuid
+            string->iso9660-uuid
+            string->ext2-uuid
+            string->ext3-uuid
+            string->ext4-uuid
+            string->btrfs-uuid
+            iso9660-uuid->string
+
+            ;; XXX: For lack of a better place.
+            sub-bytevector
+            latin1->string))
+
+
+;;;
+;;; Tools that lack a better place.
+;;;
+
+(define (sub-bytevector bv start size)
+  "Return a copy of the SIZE bytes of BV starting from offset START."
+  (let ((result (make-bytevector size)))
+    (bytevector-copy! bv start result 0 size)
+    result))
+
+(define (latin1->string bv terminator)
+  "Return a string of BV, a latin1 bytevector, or #f.  TERMINATOR is a predicate
+that takes a number and returns #t when a termination character is found."
+    (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv))))
+      (if (null? bytes)
+          #f
+          (list->string (map integer->char bytes)))))
+
+
+;;;
+;;; DCE UUIDs.
+;;;
+
+(define-syntax %network-byte-order
+  (identifier-syntax (endianness big)))
+
+(define (dce-uuid->string uuid)
+  "Convert UUID, a 16-byte bytevector, to its string representation, something
+like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
+  ;; See <https://tools.ietf.org/html/rfc4122>.
+  (let ((time-low  (bytevector-uint-ref uuid 0 %network-byte-order 4))
+        (time-mid  (bytevector-uint-ref uuid 4 %network-byte-order 2))
+        (time-hi   (bytevector-uint-ref uuid 6 %network-byte-order 2))
+        (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
+        (node      (bytevector-uint-ref uuid 10 %network-byte-order 6)))
+    (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
+            time-low time-mid time-hi clock-seq node)))
+
+(define %uuid-rx
+  ;; The regexp of a UUID.
+  (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
+
+(define (string->dce-uuid str)
+  "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
+return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
+UUID representation."
+  (and=> (regexp-exec %uuid-rx str)
+         (lambda (match)
+           (letrec-syntax ((hex->number
+                            (syntax-rules ()
+                              ((_ index)
+                               (string->number (match:substring match index)
+                                               16))))
+                           (put!
+                            (syntax-rules ()
+                              ((_ bv index (number len) rest ...)
+                               (begin
+                                 (bytevector-uint-set! bv index number
+                                                       (endianness big) len)
+                                 (put! bv (+ index len) rest ...)))
+                              ((_ bv index)
+                               bv))))
+             (let ((time-low  (hex->number 1))
+                   (time-mid  (hex->number 2))
+                   (time-hi   (hex->number 3))
+                   (clock-seq (hex->number 4))
+                   (node      (hex->number 5))
+                   (uuid      (make-bytevector 16)))
+               (put! uuid 0
+                     (time-low 4) (time-mid 2) (time-hi 2)
+                     (clock-seq 2) (node 6)))))))
+
+
+;;;
+;;; ISO-9660.
+;;;
+
+;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
+
+(define %iso9660-uuid-rx
+  ;;                   Y                m                d                H                M                S                ss
+  (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$"))
+(define (string->iso9660-uuid str)
+  "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid).
+Return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
+ISO9660 UUID representation."
+  (and=> (regexp-exec %iso9660-uuid-rx str)
+         (lambda (match)
+           (letrec-syntax ((match-numerals
+                            (syntax-rules ()
+                              ((_ index (name rest ...) body)
+                               (let ((name (match:substring match index)))
+                                 (match-numerals (+ 1 index) (rest ...) body)))
+                              ((_ index () body)
+                               body))))
+            (match-numerals 1 (year month day hour minute second hundredths)
+              (string->utf8 (string-append year month day
+                                           hour minute second hundredths)))))))
+(define (iso9660-uuid->string uuid)
+  "Given an UUID bytevector, return its timestamp string."
+  (define (digits->string bytes)
+    (latin1->string bytes (lambda (c) #f)))
+  (let* ((year (sub-bytevector uuid 0 4))
+         (month (sub-bytevector uuid 4 2))
+         (day (sub-bytevector uuid 6 2))
+         (hour (sub-bytevector uuid 8 2))
+         (minute (sub-bytevector uuid 10 2))
+         (second (sub-bytevector uuid 12 2))
+         (hundredths (sub-bytevector uuid 14 2))
+         (parts (list year month day hour minute second hundredths)))
+    (string-append (string-join (map digits->string parts) "-"))))
+
+
+;;;
+;;; FAT32.
+;;;
+
+(define-syntax %fat32-endianness
+  ;; Endianness of FAT file systems.
+  (identifier-syntax (endianness little)))
+
+(define (fat32-uuid->string uuid)
+  "Convert fat32 UUID, a 4-byte bytevector, to its string representation."
+  (let ((high  (bytevector-uint-ref uuid 0 %fat32-endianness 2))
+        (low (bytevector-uint-ref uuid 2 %fat32-endianness 2)))
+    (format #f "~:@(~x-~x~)" low high)))
+
+
+;;;
+;;; Generic interface.
+;;;
+
+(define string->ext2-uuid string->dce-uuid)
+(define string->ext3-uuid string->dce-uuid)
+(define string->ext4-uuid string->dce-uuid)
+(define string->btrfs-uuid string->dce-uuid)
+
+(define-syntax vhashq
+  (syntax-rules (=>)
+    ((_)
+     vlist-null)
+    ((_ (key others ... => value) rest ...)
+     (vhash-consq key value
+                  (vhashq (others ... => value) rest ...)))
+    ((_ (=> value) rest ...)
+     (vhashq rest ...))))
+
+(define %uuid-parsers
+  (vhashq
+   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
+   ('iso9660 => string->iso9660-uuid)))
+
+(define %uuid-printers
+  (vhashq
+   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string)
+   ('iso9660 => iso9660-uuid->string)
+   ('fat32 'fat => fat32-uuid->string)))
+
+(define* (string->uuid str #:optional (type 'dce))
+  "Parse STR as a UUID of the given TYPE.  On success, return the
+corresponding bytevector; otherwise return #f."
+  (match (vhash-assq type %uuid-parsers)
+    (#f #f)
+    ((_ . (? procedure? parse)) (parse str))))
+
+;; High-level UUID representation that carries its type with it.
+;;
+;; This is necessary to serialize bytevectors with the right printer in some
+;; circumstances.  For instance, GRUB "search --fs-uuid" command compares the
+;; string representation of UUIDs, not the raw bytes; thus, when emitting a
+;; GRUB 'search' command, we need to procedure the right string representation
+;; (see <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>).
+(define-record-type <uuid>
+  (make-uuid type bv)
+  uuid?
+  (type  uuid-type)                               ;'dce | 'iso9660 | ...
+  (bv    uuid-bytevector))
+
+(define* (bytevector->uuid bv #:optional (type 'dce))
+  "Return a UUID object make of BV and TYPE."
+  (make-uuid type bv))
+
+(define-syntax uuid
+  (lambda (s)
+    "Return the UUID object corresponding to the given UUID representation."
+    (syntax-case s (quote)
+      ((_ str (quote type))
+       (and (string? (syntax->datum #'str))
+            (identifier? #'type))
+       ;; A literal string: do the conversion at expansion time.
+       (let ((bv (string->uuid (syntax->datum #'str)
+                               (syntax->datum #'type))))
+         (unless bv
+           (syntax-violation 'uuid "invalid UUID" s))
+         #`(make-uuid 'type #,(datum->syntax s bv))))
+      ((_ str)
+       (string? (syntax->datum #'str))
+       #'(uuid str 'dce))
+      ((_ str)
+       #'(make-uuid 'dce (string->uuid str 'dce)))
+      ((_ str type)
+       #'(make-uuid type (string->uuid str type))))))
+
+(define uuid->string
+  ;; Convert the given bytevector or UUID object, to the corresponding UUID
+  ;; string representation.
+  (match-lambda*
+    (((? bytevector? bv))
+     (uuid->string bv 'dce))
+    (((? bytevector? bv) type)
+     (match (vhash-assq type %uuid-printers)
+       (#f #f)
+       ((_ . (? procedure? unparse)) (unparse bv))))
+    (((? uuid? uuid))
+     (uuid->string (uuid-bytevector uuid) (uuid-type uuid)))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 4494af0031..78143e4f7a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -57,9 +57,11 @@
   #:use-module (gnu system file-systems)
   #:use-module (gnu system)
   #:use-module (gnu services)
+  #:use-module (gnu system uuid)
 
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
 
   #:export (expression->derivation-in-linux-vm
@@ -192,6 +194,7 @@ made available under the /xchg CIFS share."
                         os-drv
                         bootcfg-drv
                         bootloader
+                        register-closures?
                         (inputs '()))
   "Return a bootable, stand-alone iso9660 image.
 
@@ -207,8 +210,13 @@ INPUTS is a list of inputs (as for packages)."
          (let ((inputs
                 '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
                            (map canonical-package
-                                (list sed grep coreutils findutils gawk))))
+                                (list sed grep coreutils findutils gawk))
+                           (if register-closures? (list guix) '())))
+
 
+               (graphs     '#$(match inputs
+                                   (((names . _) ...)
+                                    names)))
                ;; This variable is unused but allows us to add INPUTS-TO-COPY
                ;; as inputs.
                (to-register
@@ -222,8 +230,11 @@ INPUTS is a list of inputs (as for packages)."
                                #$bootcfg-drv
                                #$os-drv
                                "/xchg/guixsd.iso"
+                               #:register-closures? #$register-closures?
+                               #:closures graphs
                                #:volume-id #$file-system-label
-                               #:volume-uuid #$file-system-uuid)
+                               #:volume-uuid #$(and=> file-system-uuid
+                                                      uuid-bytevector))
            (reboot))))
    #:system system
    #:make-disk-image? #f
@@ -238,6 +249,7 @@ INPUTS is a list of inputs (as for packages)."
                      (disk-image-format "qcow2")
                      (file-system-type "ext4")
                      file-system-label
+                     file-system-uuid
                      os-drv
                      bootcfg-drv
                      bootloader
@@ -247,7 +259,10 @@ INPUTS is a list of inputs (as for packages)."
   "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.
 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
-partition.  The returned image is a full disk image that runs OS-DERIVATION,
+partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
+partition (a UUID object).
+
+The returned image is a full disk image that runs OS-DERIVATION,
 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 
@@ -297,6 +312,8 @@ the image."
                   (partitions (list (partition
                                      (size root-size)
                                      (label #$file-system-label)
+                                     (uuid #$(and=> file-system-uuid
+                                                    uuid-bytevector))
                                      (file-system #$file-system-type)
                                      (flags '(boot))
                                      (initializer initialize))
@@ -334,6 +351,35 @@ the image."
 ;;; VM and disk images.
 ;;;
 
+(define* (operating-system-uuid os #:optional (type 'dce))
+  "Compute UUID object with a deterministic \"UUID\" for OS, of the given
+TYPE (one of 'iso9660 or 'dce).  Return a UUID object."
+  (if (eq? type 'iso9660)
+      (let ((pad (compose (cut string-pad <> 2 #\0)
+                          number->string))
+            (h   (hash (operating-system-services os) 3600)))
+        (bytevector->uuid
+         (string->iso9660-uuid
+          (string-append "1970-01-01-"
+                         (pad (hash (operating-system-host-name os) 24)) "-"
+                         (pad (quotient h 60)) "-"
+                         (pad (modulo h 60)) "-"
+                         (pad (hash (operating-system-file-systems os) 100))))
+         'iso9660))
+      (bytevector->uuid
+       (uint-list->bytevector
+        (list (hash file-system-type
+                    (expt 2 32))
+              (hash (operating-system-host-name os)
+                    (expt 2 32))
+              (hash (operating-system-services os)
+                    (expt 2 32))
+              (hash (operating-system-file-systems os)
+                    (expt 2 32)))
+        (endianness little)
+        4)
+       type)))
+
 (define* (system-disk-image os
                             #:key
                             (name "disk-image")
@@ -350,12 +396,20 @@ to USB sticks meant to be read-only."
     (if (string=? "iso9660" file-system-type)
         string-upcase
         identity))
+
   (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.)
+    ;; Volume name of the root file system.
     (normalize-label "GuixSD_image"))
 
+  (define root-uuid
+    ;; UUID of the root file system, computed in a deterministic fashion.
+    ;; This is what we use to locate the root file system so it has to be
+    ;; different from the user's own file system UUIDs.
+    (operating-system-uuid os
+                           (if (string=? file-system-type "iso9660")
+                               'iso9660
+                               'dce)))
+
   (define file-systems-to-keep
     (remove (lambda (fs)
               (string=? (file-system-mount-point fs) "/"))
@@ -379,8 +433,8 @@ to USB sticks meant to be read-only."
               ;; Force our own root file system.
               (file-systems (cons (file-system
                                     (mount-point "/")
-                                    (device root-label)
-                                    (title 'label)
+                                    (device root-uuid)
+                                    (title 'uuid)
                                     (type file-system-type))
                                   file-systems-to-keep)))))
 
@@ -389,8 +443,9 @@ to USB sticks meant to be read-only."
       (if (string=? "iso9660" file-system-type)
           (iso9660-image #:name name
                          #:file-system-label root-label
-                         #:file-system-uuid #f
+                         #:file-system-uuid root-uuid
                          #:os-drv os-drv
+                         #:register-closures? #t
                          #:bootcfg-drv bootcfg
                          #:bootloader (bootloader-configuration-bootloader
                                         (operating-system-bootloader os))
@@ -403,11 +458,9 @@ to USB sticks meant to be read-only."
                                     (operating-system-bootloader os))
                       #:disk-image-size disk-image-size
                       #:disk-image-format "raw"
-                      #:file-system-type (if (string=? "iso9660"
-                                                       file-system-type)
-                                             "ext4"
-                                             file-system-type)
+                      #:file-system-type file-system-type
                       #:file-system-label root-label
+                      #:file-system-uuid root-uuid
                       #:copy-inputs? #t
                       #:register-closures? #t
                       #:inputs `(("system" ,os-drv)