From 4138e782dcfea675ebc2347cbd4ea9abeb9dff36 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 3 Sep 2017 10:56:25 +0100
Subject: vm: Remove redundant conditional in system-disk-image.

* gnu/system/vm.scm (system-disk-image): Remove redundant conditional for
  #:file-system-type when calling qemu-image.
---
 gnu/system/vm.scm | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

(limited to 'gnu/system')

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 4494af0031..b3da118765 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -403,10 +403,7 @@ 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
                       #:copy-inputs? #t
                       #:register-closures? #t
-- 
cgit v1.2.3


From e375d3fab7a64246f9c1caa4b23a280f5b84ebc6 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 3 Sep 2017 11:48:20 +0100
Subject: vm: Add support for registering closures to iso9660-image.

* gnu/system/vm.scm (iso9660-image): Add support for registering closures.
---
 gnu/system/vm.scm | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

(limited to 'gnu/system')

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index b3da118765..f7a711a72b 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -192,6 +192,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 +208,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,6 +228,8 @@ 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)
            (reboot))))
-- 
cgit v1.2.3


From b069111f7a5d2c4596b9bc796fd0f56b77eb4c4e Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 3 Sep 2017 11:48:27 +0100
Subject: vm: Call iso9660-image with #:register-closures? as #t.

* gnu/system/vm.scm (system-disk-image): Call iso9660-image with
  #:register-closures? as #t.
---
 gnu/system/vm.scm | 1 +
 1 file changed, 1 insertion(+)

(limited to 'gnu/system')

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index f7a711a72b..b106dff0a8 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -399,6 +399,7 @@ to USB sticks meant to be read-only."
                          #:file-system-label root-label
                          #:file-system-uuid #f
                          #:os-drv os-drv
+                         #:register-closures? #t
                          #:bootcfg-drv bootcfg
                          #:bootloader (bootloader-configuration-bootloader
                                         (operating-system-bootloader os))
-- 
cgit v1.2.3


From 903ae630a0ae0df9fabd5ebab7d44577d6e7d0fc Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 10 Sep 2017 21:40:46 +0200
Subject: install: Add 'passwd' to $PATH.

Suggested by Jan Nieuwenhuizen.

* gnu/system/install.scm (installation-os)[setuid-programs]: Add 'passwd'.
---
 gnu/system/install.scm | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'gnu/system')

diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 7f6ffe9582..5c0aaed18a 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -337,9 +337,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.
-- 
cgit v1.2.3


From 1e8d398abca66bbe85caad6d338ac80a104701d2 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 10 Sep 2017 21:45:12 +0200
Subject: install: Add OpenSSH to the global profile.

Suggested by Jan Nieuwenhuizen.

* gnu/system/install.scm (installation-os)[packages]: Add OPENSSH.
---
 gnu/system/install.scm | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'gnu/system')

diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 5c0aaed18a..4aecfaca2c 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)
@@ -352,6 +353,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
-- 
cgit v1.2.3


From 47cef4ecad54d112aa3b4bc509194d3d49a10785 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 5 Sep 2017 21:51:12 +0200
Subject: file-systems: Introduce (gnu system uuid).

* gnu/build/file-systems.scm (sub-bytevector)
(latin1->string, %fat32-endianness, fat32-uuid->string)
(%iso9660-uuid-rx, string->iso9660-uuid)
(iso9660-uuid->string, %network-byte-order)
(dce-uuid->string, %uuid-rx, string->dce-uuid)
(string->ext2-uuid, string->ext3-uuid, string->ext4-uuid)
(vhashq, %uuid-parsers, %uuid-printers, string->uuid)
(uuid->string): Move to...
* gnu/system/uuid.scm: ... here.  New file.
* gnu/system/file-systems.scm (uuid): Move to the above file.
* gnu/system/vm.scm: Adjust accordingly.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add uuid.scm.
---
 gnu/build/file-systems.scm  | 167 +-------------------------------
 gnu/build/vm.scm            |   2 +-
 gnu/local.mk                |   1 +
 gnu/system/file-systems.scm |  22 +----
 gnu/system/uuid.scm         | 227 ++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 234 insertions(+), 185 deletions(-)
 create mode 100644 gnu/system/uuid.scm

(limited to 'gnu/system')

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index fbaf158951..32885f1d2e 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -19,6 +19,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build file-systems)
+  #:use-module (gnu system uuid)
   #:use-module (guix build utils)
   #:use-module (guix build bournish)
   #:use-module (guix build syscalls)
@@ -26,9 +27,6 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 format)
-  #:use-module (ice-9 regex)
-  #:use-module (ice-9 vlist)
   #:use-module (system foreign)
   #:autoload   (system repl repl) (start-repl)
   #:use-module (srfi srfi-1)
@@ -42,17 +40,6 @@
             find-partition-by-luks-uuid
             canonicalize-device-spec
 
-            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
-
             bind-mount
 
             mount-flags->bit-mask
@@ -98,20 +85,6 @@ takes a bytevector and returns #t when it's a valid superblock."
                      (and (magic? block)
                           block)))))))))
 
-(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)))))
-
 (define null-terminated-latin1->string
   (cut latin1->string <> zero?))
 
@@ -199,10 +172,6 @@ if DEVICE does not contain a btrfs file system."
 
 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.
 
-(define-syntax %fat32-endianness
-  ;; Endianness of fat file systems.
-  (identifier-syntax (endianness little)))
-
 (define (fat32-superblock? sblock)
   "Return #t when SBLOCK is a fat32 superblock."
   (bytevector=? (sub-bytevector sblock 82 8)
@@ -217,12 +186,6 @@ if DEVICE does not contain a btrfs file system."
   "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
   (sub-bytevector sblock 67 4))
 
-(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)))
-
 (define (fat32-superblock-volume-name sblock)
   "Return the volume name of SBLOCK as a string of at most 11 characters, or
 #f if SBLOCK has no volume name.  The volume name is a latin1 string.
@@ -244,27 +207,6 @@ Trailing spaces are trimmed."
 
 ;; <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-superblock? sblock)
   "Return #t when SBLOCK is an iso9660 volume descriptor."
   (bytevector=? (sub-bytevector sblock 1 6)
@@ -311,20 +253,6 @@ SBLOCK as a bytevector.  If that's not set, returns the creation time."
                    modification-time)))
     (sub-bytevector time 0 16))) ; strips GMT offset.
 
-(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) "-"))))
-
 (define (iso9660-superblock-volume-name sblock)
   "Return the volume name of SBLOCK as a string.  The volume name is an ASCII
 string.  Trailing spaces are trimmed."
@@ -511,99 +439,6 @@ were found."
 (define find-partition-by-luks-uuid
   (find-partition luks-partition-uuid-predicate))
 
-
-;;;
-;;; 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)))))))
-
-(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 #:key (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))))
-
-(define* (uuid->string bv #:key (type 'dce))
-  "Convert BV, a bytevector, to the UUID string representation for TYPE."
-  (match (vhash-assq type %uuid-printers)
-    (#f #f)
-    ((_ . (? procedure? unparse)) (unparse bv))))
-
 
 (define* (canonicalize-device-spec spec #:optional (title 'any))
   "Return the device name corresponding to SPEC.  TITLE is a symbol, one of
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index ad67a3727f..6da4fa654e 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -26,7 +26,7 @@
   #:use-module (guix build syscalls)
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
-  #:use-module (gnu build file-systems)
+  #:use-module (gnu system uuid)
   #:use-module (guix records)
   #:use-module ((guix combinators) #:select (fold2))
   #:use-module (ice-9 format)
diff --git a/gnu/local.mk b/gnu/local.mk
index e98ee6d7fe..c1bc391101 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -468,6 +468,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/system/nss.scm				\
   %D%/system/pam.scm				\
   %D%/system/shadow.scm				\
+  %D%/system/uuid.scm				\
   %D%/system/vm.scm				\
 						\
   %D%/build/activation.scm			\
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index bbac23fbdf..dd30559d7e 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -20,9 +20,10 @@
   #: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)
+                #:select (uuid string->uuid uuid->string))
+  #:re-export (uuid                               ;backward compatibility
+               string->uuid
                uuid->string)
   #:export (<file-system>
             file-system
@@ -44,7 +45,6 @@
             file-system->spec
             spec->file-system
             specification->file-system-mapping
-            uuid
 
             %fuse-control-file-system
             %binary-format-file-system
@@ -186,20 +186,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/uuid.scm b/gnu/system/uuid.scm
new file mode 100644
index 0000000000..64dad5a374
--- /dev/null
+++ b/gnu/system/uuid.scm
@@ -0,0 +1,227 @@
+;;; 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 (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->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 #:key (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))))
+
+(define* (uuid->string bv #:key (type 'dce))
+  "Convert BV, a bytevector, to the UUID string representation for TYPE."
+  (match (vhash-assq type %uuid-printers)
+    (#f #f)
+    ((_ . (? procedure? unparse)) (unparse bv))))
+
+(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)))))
-- 
cgit v1.2.3


From 9b336338cdc0e46a3bf7a2913c2f61cd2410c4d6 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 6 Sep 2017 09:28:28 +0200
Subject: system: Introduce a disjoint UUID type.

Conceptually a UUID is just a bytevector.  However, there's software out
there such as GRUB that relies on the string representation of different
UUID types (e.g., the string representation of DCE UUIDs differs from
that of ISO-9660 UUIDs, even if they are actually bytevectors of the
same length).  This new <uuid> record type allows us to preserve
information about the type of UUID so we can eventually convert it to a
string using the right representation.

* gnu/system/uuid.scm (<uuid>): New record type.
(bytevector->uuid): New procedure.
(uuid): Return calls to 'make-uuid'.
(uuid->string): Rewrite using 'match-lambda*' to accept a single 'uuid?'
argument.
* gnu/bootloader/grub.scm (grub-root-search): Check for 'uuid?' instead
of 'bytevector?'.
* gnu/system.scm (bootable-kernel-arguments): Check whether ROOT-DEVICE
is 'uuid?'.
(read-boot-parameters): Use 'bytevector->uuid' when the
store device is a bytevector.
(read-boot-parameters-file): Check for 'uuid?' instead of 'bytevector?'.
(device->sexp): New procedure.
(operating-system-boot-parameters-file): Use it for 'root-device' and
'store'.
(operating-system-bootcfg): Remove conditional in definition of
'root-device'.
* gnu/system/file-systems.scm (file-system->spec): Check for 'uuid?' on
DEVICE and take its bytevector.
* gnu/system/mapped-devices.scm (open-luks-device): Likewise.
* gnu/system/vm.scm (iso9660-image): Call 'uuid-bytevector' for the
 #:volume-uuid argument.
---
 gnu/bootloader/grub.scm       |  4 ++--
 gnu/system.scm                | 38 ++++++++++++++++++++++++----------
 gnu/system/file-systems.scm   |  8 +++++---
 gnu/system/mapped-devices.scm |  7 +++++--
 gnu/system/uuid.scm           | 48 +++++++++++++++++++++++++++++++++++--------
 gnu/system/vm.scm             |  4 +++-
 6 files changed, 82 insertions(+), 27 deletions(-)

(limited to 'gnu/system')

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index a9f0875f36..96e53c5c2b 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -30,7 +30,7 @@
   #:use-module (gnu artwork)
   #:use-module (gnu system)
   #:use-module (gnu bootloader)
-  #:use-module (gnu system file-systems)
+  #:use-module (gnu system uuid)
   #:autoload   (gnu packages bootloaders) (grub)
   #:autoload   (gnu packages compression) (gzip)
   #:autoload   (gnu packages gtk) (guile-cairo guile-rsvg)
@@ -300,7 +300,7 @@ code."
       (match device
         ;; Preferably refer to DEVICE by its UUID or label.  This is more
         ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
-        ((? bytevector? uuid)
+        ((? uuid? uuid)
          (format #f "search --fs-uuid --set ~a"
                  (uuid->string device)))
         ((? string? label)
diff --git a/gnu/system.scm b/gnu/system.scm
index 6b35e3c0c7..a8d2a81316 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -54,6 +54,7 @@
   #:use-module (gnu system locale)
   #:use-module (gnu system pam)
   #:use-module (gnu system linux-initrd)
+  #:use-module (gnu system uuid)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system mapped-devices)
   #:use-module (ice-9 match)
@@ -128,7 +129,14 @@
 (define (bootable-kernel-arguments kernel-arguments system.drv root-device)
   "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be
 booted from ROOT-DEVICE"
-  (cons* (string-append "--root=" root-device)
+  (cons* (string-append "--root="
+                        (if (uuid? root-device)
+
+                            ;; Note: Always use the DCE format because that's
+                            ;; what (gnu build linux-boot) expects for the
+                            ;; '--root' kernel command-line option.
+                            (uuid->string (uuid-bytevector root-device) 'dce)
+                            root-device))
          #~(string-append "--system=" #$system.drv)
          #~(string-append "--load=" #$system.drv "/boot")
          kernel-arguments))
@@ -261,6 +269,8 @@ directly by the user."
 
       (store-device
        (match (assq 'store rest)
+         (('store ('device (? bytevector? bv)) _ ...)
+          (bytevector->uuid bv))
          (('store ('device device) _ ...)
           device)
          (_                                       ;the old format
@@ -289,16 +299,12 @@ The object has its kernel-arguments extended in order to make it bootable."
   (let* ((file (string-append system "/parameters"))
          (params (call-with-input-file file read-boot-parameters))
          (root (boot-parameters-root-device params))
-         (root-device (if (bytevector? root)
-                          (uuid->string root)
-                          root))
          (kernel-arguments (boot-parameters-kernel-arguments params)))
     (if params
       (boot-parameters
         (inherit params)
         (kernel-arguments (bootable-kernel-arguments kernel-arguments
-                                                     system
-                                                     root-device)))
+                                                     system root)))
       #f)))
 
 (define (boot-parameters->menu-entry conf)
@@ -875,9 +881,7 @@ listed in OS.  The C library expects to find it under
   (mlet* %store-monad
       ((system      (operating-system-derivation os))
        (root-fs ->  (operating-system-root-file-system os))
-       (root-device -> (if (eq? 'uuid (file-system-title root-fs))
-                           (uuid->string (file-system-device root-fs))
-                           (file-system-device root-fs)))
+       (root-device -> (file-system-device root-fs))
        (params (operating-system-boot-parameters os system root-device))
        (entry -> (boot-parameters->menu-entry params))
        (bootloader-conf -> (operating-system-bootloader os)))
@@ -917,6 +921,15 @@ kernel arguments for that derivation to <boot-parameters>."
              (store-device (fs->boot-device store))
              (store-mount-point (file-system-mount-point store))))))
 
+(define (device->sexp device)
+  "Serialize DEVICE as an sexp (really, as an object with a read syntax.)"
+  (match device
+    ((? uuid? uuid)
+     ;; TODO: Preserve the type of UUID.
+     (uuid-bytevector uuid))
+    (_
+     device)))
+
 (define* (operating-system-boot-parameters-file os #:optional (system.drv #f))
    "Return a file that describes the boot parameters of OS.  The primary use of
 this file is the reconstruction of GRUB menu entries for old configurations.
@@ -934,14 +947,17 @@ being stored into the \"parameters\" file)."
                  #~(boot-parameters
                     (version 0)
                     (label #$(boot-parameters-label params))
-                    (root-device #$(boot-parameters-root-device params))
+                    (root-device
+                     #$(device->sexp
+                        (boot-parameters-root-device params)))
                     (kernel #$(boot-parameters-kernel params))
                     (kernel-arguments
                      #$(boot-parameters-kernel-arguments params))
                     (initrd #$(boot-parameters-initrd params))
                     (bootloader-name #$(boot-parameters-bootloader-name params))
                     (store
-                     (device #$(boot-parameters-store-device params))
+                     (device
+                      #$(device->sexp (boot-parameters-store-device params)))
                      (mount-point #$(boot-parameters-store-mount-point params))))
                  #:set-load-path? #f)))
 
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index dd30559d7e..52f16676f5 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -20,8 +20,7 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (guix records)
-  #:use-module ((gnu system uuid)
-                #:select (uuid string->uuid uuid->string))
+  #:use-module (gnu system uuid)
   #:re-export (uuid                               ;backward compatibility
                string->uuid
                uuid->string)
@@ -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."
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
index 64dad5a374..60626ebb12 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -19,12 +19,19 @@
 
 (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
@@ -206,15 +213,27 @@ corresponding bytevector; otherwise return #f."
     (#f #f)
     ((_ . (? procedure? parse)) (parse str))))
 
-(define* (uuid->string bv #:key (type 'dce))
-  "Convert BV, a bytevector, to the UUID string representation for TYPE."
-  (match (vhash-assq type %uuid-printers)
-    (#f #f)
-    ((_ . (? procedure? unparse)) (unparse bv))))
+;; 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 bytevector corresponding to the given UUID representation."
+    "Return the UUID object corresponding to the given UUID representation."
+    ;; TODO: Extend to types other than DCE.
     (syntax-case s ()
       ((_ str)
        (string? (syntax->datum #'str))
@@ -222,6 +241,19 @@ corresponding bytevector; otherwise return #f."
        (let ((bv (string->uuid (syntax->datum #'str))))
          (unless bv
            (syntax-violation 'uuid "invalid UUID" s))
-         (datum->syntax #'str bv)))
+         #`(make-uuid 'dce #,(datum->syntax #'str bv))))
       ((_ str)
-       #'(string->uuid str)))))
+       #'(make-uuid 'dce (string->uuid str))))))
+
+(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 b106dff0a8..92f0444ed8 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -57,6 +57,7 @@
   #: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)
@@ -231,7 +232,8 @@ INPUTS is a list of inputs (as for packages)."
                                #: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
-- 
cgit v1.2.3


From ce094b4663da6aa52d02f398a19e1d2892641b7d Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 6 Sep 2017 10:35:01 +0200
Subject: uuid: 'uuid' macro supports more UUID types.

* gnu/system/uuid.scm (string->uuid): Turn 'type' into an optional
argument.
(uuid): Add clauses to allow for an optional 'type' parameter.
---
 gnu/system/uuid.scm | 22 ++++++++++++++--------
 1 file changed, 14 insertions(+), 8 deletions(-)

(limited to 'gnu/system')

diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index 60626ebb12..1dd6a11339 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -206,7 +206,7 @@ ISO9660 UUID representation."
    ('iso9660 => iso9660-uuid->string)
    ('fat32 'fat => fat32-uuid->string)))
 
-(define* (string->uuid str #:key (type 'dce))
+(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)
@@ -233,17 +233,23 @@ corresponding bytevector; otherwise return #f."
 (define-syntax uuid
   (lambda (s)
     "Return the UUID object corresponding to the given UUID representation."
-    ;; TODO: Extend to types other than DCE.
-    (syntax-case s ()
-      ((_ str)
-       (string? (syntax->datum #'str))
+    (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))))
+       (let ((bv (string->uuid (syntax->datum #'str)
+                               (syntax->datum #'type))))
          (unless bv
            (syntax-violation 'uuid "invalid UUID" s))
-         #`(make-uuid 'dce #,(datum->syntax #'str bv))))
+         #`(make-uuid 'type #,(datum->syntax s bv))))
+      ((_ str)
+       (string? (syntax->datum #'str))
+       #'(uuid str 'dce))
       ((_ str)
-       #'(make-uuid 'dce (string->uuid 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
-- 
cgit v1.2.3


From fd3b4b985d5bbd5d91362aa91079c1155018fa34 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 6 Sep 2017 23:12:32 +0200
Subject: vm: Allow users to specify a UUID for the root partition.

* gnu/system/vm.scm (qemu-image): Add #:file-system-uuid parameter; pass
it as the 'uuid' field of the root partition.
---
 gnu/system/vm.scm | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

(limited to 'gnu/system')

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 92f0444ed8..9e900182ae 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -248,6 +248,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
@@ -257,7 +258,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.)
 
@@ -307,6 +311,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))
-- 
cgit v1.2.3


From 5f7fe1c57ecb9525aa7e13e38af2aab022bae078 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 6 Sep 2017 23:16:09 +0200
Subject: vm: Generate a UUID to identify the root file system.

This makes collisions less likely than when using a label to look up the
partition.  See <https://bugs.gnu.org/27735>.

* gnu/system/vm.scm (operating-system-uuid): New procedure.
(system-disk-image): Define 'root-uuid' and use it for the root file
system.  Pass it to 'iso9660-image' and 'qemu-image'.
---
 gnu/system/vm.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 45 insertions(+), 6 deletions(-)

(limited to 'gnu/system')

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 9e900182ae..78143e4f7a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -61,6 +61,7 @@
 
   #: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
@@ -350,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")
@@ -366,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) "/"))
@@ -395,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)))))
 
@@ -405,7 +443,7 @@ 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
@@ -422,6 +460,7 @@ to USB sticks meant to be read-only."
                       #:disk-image-format "raw"
                       #: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)
-- 
cgit v1.2.3


From 4e854b1814a9216ae7cc90aef4d82fd989a519c3 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 12 Sep 2017 22:28:43 +0200
Subject: install: Include the whole bare-bones OS in the image.

* gnu/system/install.scm (%installation-services): Load
"example/bare-bones.tmpl".  Add a 'gc-root-service-type' instance.
---
 gnu/system/install.scm | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

(limited to 'gnu/system')

diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 4aecfaca2c..eb362f91a8 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -215,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")))
@@ -284,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.
-- 
cgit v1.2.3


From 960c40de21650368021b20c78b79101bce022b51 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 12 Sep 2017 22:35:12 +0200
Subject: doc: Use Screen and OpenSSH in the bare-bones example.

* gnu/system/examples/bare-bones.tmpl (packages): Remove TCPDUMP; add
SCREEN and OPENSSH.
* doc/guix.texi (Using the Configuration System): Adjust explanation
accordingly.
---
 doc/guix.texi                       | 5 +++--
 gnu/system/examples/bare-bones.tmpl | 4 ++--
 2 files changed, 5 insertions(+), 4 deletions(-)

(limited to 'gnu/system')

diff --git a/doc/guix.texi b/doc/guix.texi
index c5b277d027..0633691228 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8186,8 +8186,9 @@ environment variable---in addition to the per-user profiles
 provides all the tools one would expect for basic user and administrator
 tasks---including the GNU Core Utilities, the GNU Networking Utilities,
 the GNU Zile lightweight text editor, @command{find}, @command{grep},
-etc.  The example above adds tcpdump to those, taken from the @code{(gnu
-packages admin)} module (@pxref{Package Modules}).  The
+etc.  The example above adds GNU@tie{}Screen and OpenSSH to those,
+taken from the @code{(gnu packages screen)} and @code{(gnu packages ssh)}
+modules (@pxref{Package Modules}).  The
 @code{(list package output)} syntax can be used to add a specific output
 of a package:
 
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.
-- 
cgit v1.2.3


From fbc31dc1247d3a494246e69f3cf28476af9eb9d6 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 21 Sep 2017 23:52:45 +0200
Subject: services: Move 'session-environment-service-type' to pam.scm.

* gnu/services/base.scm (environment-variables->environment-file)
(session-environment-service-type)
(session-environment-service): Move to...
* gnu/system/pam.scm: ... here.
---
 gnu/services/base.scm | 43 -------------------------------------------
 gnu/system/pam.scm    | 47 ++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 46 insertions(+), 44 deletions(-)

(limited to 'gnu/system')

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 10c8f1b6a3..64620a9b0a 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -59,8 +59,6 @@
             user-unmount-service
             swap-service
             user-processes-service
-            session-environment-service
-            session-environment-service-type
             host-name-service
             console-keymap-service
             %default-console-font
@@ -600,47 +598,6 @@ to add @var{device} to the kernel's entropy pool.  The service will fail if
             (rng-tools rng-tools)
             (device device))))
 
-
-;;;
-;;; System-wide environment variables.
-;;;
-
-(define (environment-variables->environment-file vars)
-  "Return a file for pam_env(8) that contains environment variables VARS."
-  (apply mixed-text-file "environment"
-         (append-map (match-lambda
-                       ((key . value)
-                        (list key "=" value "\n")))
-                     vars)))
-
-(define session-environment-service-type
-  (service-type
-   (name 'session-environment)
-   (extensions
-    (list (service-extension
-           etc-service-type
-           (lambda (vars)
-             (list `("environment"
-                     ,(environment-variables->environment-file vars)))))))
-   (compose concatenate)
-   (extend append)
-   (description
-    "Populate @file{/etc/environment} with the specified environment
-variables.  The value of this service is a list of name/value pairs for
-environments variables, such as:
-
-@example
-'((\"TZ\" . \"Canada/Pacific\"))
-@end example\n")))
-
-(define (session-environment-service vars)
-  "Return a service that builds the @file{/etc/environment}, which can be read
-by PAM-aware applications to set environment variables for sessions.
-
-VARS should be an association list in which both the keys and the values are
-strings or string-valued gexps."
-  (service session-environment-service-type vars))
-
 
 ;;;
 ;;; Console & co.
diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm
index eedf933946..13f76a50ed 100644
--- a/gnu/system/pam.scm
+++ b/gnu/system/pam.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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -50,6 +50,9 @@
             unix-pam-service
             base-pam-services
 
+            session-environment-service
+            session-environment-service-type
+
             pam-root-service-type
             pam-root-service))
 
@@ -276,6 +279,48 @@ authenticate to run COMMAND."
                '("useradd" "userdel" "usermod"
                  "groupadd" "groupdel" "groupmod"))))
 
+
+;;;
+;;; System-wide environment variables.
+;;;
+
+(define (environment-variables->environment-file vars)
+  "Return a file for pam_env(8) that contains environment variables VARS."
+  (apply mixed-text-file "environment"
+         (append-map (match-lambda
+                       ((key . value)
+                        (list key "=" value "\n")))
+                     vars)))
+
+(define session-environment-service-type
+  (service-type
+   (name 'session-environment)
+   (extensions
+    (list (service-extension
+           etc-service-type
+           (lambda (vars)
+             (list `("environment"
+                     ,(environment-variables->environment-file vars)))))))
+   (compose concatenate)
+   (extend append)
+   (description
+    "Populate @file{/etc/environment}, which is honored by @code{pam_env},
+with the specified environment variables.  The value of this service is a list
+of name/value pairs for environments variables, such as:
+
+@example
+'((\"TZ\" . \"Canada/Pacific\"))
+@end example\n")))
+
+(define (session-environment-service vars)
+  "Return a service that builds the @file{/etc/environment}, which can be read
+by PAM-aware applications to set environment variables for sessions.
+
+VARS should be an association list in which both the keys and the values are
+strings or string-valued gexps."
+  (service session-environment-service-type vars))
+
+
 
 ;;;
 ;;; PAM root service.
-- 
cgit v1.2.3


From 8a7d81a5e23c4d59fbabf2550db32d4ba5572e4b Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 22 Sep 2017 18:25:21 +0200
Subject: uuid: Add a parser for FAT32 UUIDs.

* gnu/system/uuid.scm (%fat32-uuid-rx): New variable.
(string->fat32-uuid): New procedure.
(%uuid-parsers): Add it.
* tests/uuid.scm ("uuid, FAT32, format preserved"): New test.
---
 gnu/system/uuid.scm | 18 ++++++++++++++++++
 tests/uuid.scm      |  4 ++++
 2 files changed, 22 insertions(+)

(limited to 'gnu/system')

diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index 1dd6a11339..6470abb8cc 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -41,6 +41,7 @@
             string->ext3-uuid
             string->ext4-uuid
             string->btrfs-uuid
+            string->fat32-uuid
             iso9660-uuid->string
 
             ;; XXX: For lack of a better place.
@@ -175,6 +176,22 @@ ISO9660 UUID representation."
         (low (bytevector-uint-ref uuid 2 %fat32-endianness 2)))
     (format #f "~:@(~x-~x~)" low high)))
 
+(define %fat32-uuid-rx
+  (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$"))
+
+(define (string->fat32-uuid str)
+  "Parse STR, which is in FAT32 format, and return a bytevector or #f."
+  (match (regexp-exec %fat32-uuid-rx str)
+    (#f
+     #f)
+    (rx-match
+     (uint-list->bytevector (list (string->number
+                                   (match:substring rx-match 2) 16)
+                                  (string->number
+                                   (match:substring rx-match 1) 16))
+                            %fat32-endianness
+                            2))))
+
 
 ;;;
 ;;; Generic interface.
@@ -198,6 +215,7 @@ ISO9660 UUID representation."
 (define %uuid-parsers
   (vhashq
    ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
+   ('fat32 'fat => string->fat32-uuid)
    ('iso9660 => string->iso9660-uuid)))
 
 (define %uuid-printers
diff --git a/tests/uuid.scm b/tests/uuid.scm
index c2f15de996..aacce77233 100644
--- a/tests/uuid.scm
+++ b/tests/uuid.scm
@@ -53,4 +53,8 @@
   "1970-01-01-17-14-42-99"
   (uuid->string (uuid "1970-01-01-17-14-42-99" 'iso9660)))
 
+(test-equal "uuid, FAT32, format preserved"
+  "1234-ABCD"
+  (uuid->string (uuid "1234-abcd" 'fat32)))
+
 (test-end)
-- 
cgit v1.2.3