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

9 files changed, 172 insertions, 95 deletions

diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl
index 3931bad60d..716b9feb8d 100644
--- a/gnu/system/examples/desktop.tmpl
+++ b/gnu/system/examples/desktop.tmpl
@@ -42,9 +42,11 @@
                          (type "vfat")))
                  %base-file-systems))
 
+  ;; Create user `bob' with `alice' as its initial password.
   (users (cons (user-account
                 (name "bob")
                 (comment "Alice's brother")
+                (password (crypt "alice" "$6$abc"))
                 (group "users")
                 (supplementary-groups '("wheel" "netdev"
                                         "audio" "video")))
diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl
index 20b122fe51..b4037d4f79 100644
--- a/gnu/system/examples/lightweight-desktop.tmpl
+++ b/gnu/system/examples/lightweight-desktop.tmpl
@@ -4,7 +4,6 @@
 
 (use-modules (gnu) (gnu system nss))
 (use-service-modules desktop)
-(use-package-modules bootloaders certs ratpoison suckless wm)
 (use-package-modules bootloaders certs ratpoison suckless wm xorg)
 
 (operating-system
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 0f94577760..5c02dfac93 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
@@ -28,6 +28,8 @@
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (guix records)
+  #:use-module ((guix diagnostics) #:select (&fix-hint))
+  #:use-module (guix i18n)
   #:use-module (gnu system uuid)
   #:re-export (uuid                               ;backward compatibility
                string->uuid
@@ -46,6 +48,7 @@
             alist->file-system-options
 
             file-system-mount?
+            file-system-mount-may-fail?
             file-system-check?
             file-system-create-mount-point?
             file-system-dependencies
@@ -66,6 +69,8 @@
             %pseudo-file-system-types
             %fuse-control-file-system
             %binary-format-file-system
+            %debug-file-system
+            %efivars-file-system
             %shared-memory-file-system
             %pseudo-terminal-file-system
             %tty-gid
@@ -111,6 +116,8 @@
                     (default #f))
   (mount?           file-system-mount?            ; Boolean
                     (default #t))
+  (mount-may-fail?  file-system-mount-may-fail?   ; Boolean
+                    (default #f))
   (needed-for-boot? %file-system-needed-for-boot? ; Boolean
                     (default #f))
   (check?           file-system-check?            ; Boolean
@@ -298,18 +305,21 @@ store--e.g., if FS is the root file system."
   "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?)
+    (($ <file-system> device mount-point type flags options mount?
+                      mount-may-fail? needed-for-boot? check?)
+     ;; Note: Add new fields towards the end for compatibility.
      (list (cond ((uuid? device)
                   `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
                  ((file-system-label? device)
                   `(file-system-label ,(file-system-label->string device)))
                  (else device))
-           mount-point type flags options check?))))
+           mount-point type flags options mount-may-fail? check?))))
 
 (define (spec->file-system sexp)
   "Deserialize SEXP, a list, to the corresponding <file-system> object."
   (match sexp
-    ((device mount-point type flags options check?)
+    ((device mount-point type flags options mount-may-fail? check?
+             _ ...)                               ;placeholder for new fields
      (file-system
        (device (match device
                  (('uuid (? symbol? type) (? bytevector? bv))
@@ -320,6 +330,7 @@ initrd code."
                   device)))
        (mount-point mount-point) (type type)
        (flags flags) (options options)
+       (mount-may-fail? mount-may-fail?)
        (check? check?)))))
 
 (define (specification->file-system-mapping spec writable?)
@@ -366,6 +377,24 @@ TARGET in the other system."
     (type "binfmt_misc")
     (check? #f)))
 
+(define %debug-file-system
+  (file-system
+    (type "debugfs")
+    (device "none")
+    (mount-point "/sys/kernel/debug")
+    (check? #f)
+    (create-mount-point? #t)))
+
+(define %efivars-file-system
+  ;; Support for EFI variables file system.
+  (file-system
+    (device "efivarfs")
+    (mount-point "/sys/firmware/efi/efivars")
+    (type "efivarfs")
+    (mount-may-fail? #t)
+    (needed-for-boot? #f)
+    (check? #f)))
+
 (define %tty-gid
   ;; ID of the 'tty' group.  Allocate it statically to make it easy to refer
   ;; to it from here and from the 'tty' group definitions.
@@ -465,7 +494,9 @@ TARGET in the other system."
   ;; List of basic file systems to be mounted.  Note that /proc and /sys are
   ;; currently mounted by the initrd.
   (list %pseudo-terminal-file-system
+        %debug-file-system
         %shared-memory-file-system
+        %efivars-file-system
         %immutable-store))
 
 ;; File systems for Linux containers differ from %base-file-systems in that
@@ -613,12 +644,13 @@ store is located, else #f."
     ;; XXX: Deriving the subvolume name based from a subvolume ID is not
     ;; supported, as we'd need to query the actual file system.
     (or (and=> (assoc-ref options "subvol") prepend-slash/maybe)
-        ;; FIXME: Use &fix-hint once it no longer pulls in (guix utils).
         (raise (condition
                 (&message
                  (message "The store is on a Btrfs subvolume, but the \
-subvolume name is unknown.
-Hint: Use the \"subvol\" Btrfs file system option.")))))))
+subvolume name is unknown."))
+                (&fix-hint
+                 (hint
+                  (G_ "Use the @code{subvol} Btrfs file system option."))))))))
 
 
 ;;; file-systems.scm ends here
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 36f56e237d..97c7021454 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -63,7 +63,8 @@
             iso9660-image
 
             find-image
-            system-image))
+            system-image
+            image-with-label))
 
 
 ;;;
@@ -404,6 +405,20 @@ used in the image. "
                    #:options `(#:references-graphs ,inputs
                                #:substitutable? ,substitutable?))))
 
+(define (image-with-label base-image label)
+  "The volume ID of an ISO is the label of the first partition.  This procedure
+returns an image record where the first partition's label is set to <label>."
+  (image
+    (inherit base-image)
+    (partitions
+      (match (image-partitions base-image)
+        ((boot others ...)
+         (cons
+           (partition
+             (inherit boot)
+             (label label))
+           others))))))
+
 
 ;;
 ;; Image creation.
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index d0ff2e7c52..be5a678cec 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -175,39 +175,6 @@ manual."
   ;; Sub-directory used as the backing store for copy-on-write.
   "/tmp/guix-inst")
 
-(define (make-cow-store target)
-  "Return a gexp that makes the store copy-on-write, using TARGET as the
-backing store.  This is useful when TARGET is on a hard disk, whereas the
-current store is on a RAM disk."
-
-  (define (set-store-permissions directory)
-    ;; Set the right perms on DIRECTORY to use it as the store.
-    #~(begin
-        (chown #$directory 0 30000)             ;use the fixed 'guixbuild' GID
-        (chmod #$directory #o1775)))
-
-  #~(begin
-      ;; Bind-mount TARGET's /tmp in case we need space to build things.
-      (let ((tmpdir (string-append #$target "/tmp")))
-        (mkdir-p tmpdir)
-        (mount tmpdir "/tmp" "none" MS_BIND))
-
-      (let* ((rw-dir (string-append target #$%backing-directory))
-             (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
-        (mkdir-p rw-dir)
-        (mkdir-p work-dir)
-        (mkdir-p "/.rw-store")
-        #$(set-store-permissions #~rw-dir)
-        #$(set-store-permissions "/.rw-store")
-
-        ;; Mount the overlay, then atomically make it the store.
-        (mount "none" "/.rw-store" "overlay" 0
-               (string-append "lowerdir=" #$(%store-prefix) ","
-                              "upperdir=" rw-dir ","
-                              "workdir=" work-dir))
-        (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE)
-        (rmdir "/.rw-store"))))
-
 (define cow-store-service-type
   (shepherd-service-type
    'cow-store
@@ -222,13 +189,18 @@ the given target.")
       ;; This is meant to be explicitly started by the user.
       (auto-start? #f)
 
-      (start #~(case-lambda
-                 ((target)
-                  #$(make-cow-store #~target)
-                  target)
-                 (else
-                  ;; Do nothing, and mark the service as stopped.
-                  #f)))
+      (modules `((gnu build install)
+                 ,@%default-modules))
+      (start
+       (with-imported-modules (source-module-closure
+                               '((gnu build install)))
+         #~(case-lambda
+             ((target)
+              (mount-cow-store target #$%backing-directory)
+              target)
+             (else
+              ;; Do nothing, and mark the service as stopped.
+              #f))))
       (stop #~(lambda (target)
                 ;; Delete the temporary directory, but leave everything
                 ;; mounted as there may still be processes using it since
@@ -497,6 +469,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
             ;; elogind's cgroup file systems.
             (list %pseudo-terminal-file-system
                   %shared-memory-file-system
+                  %efivars-file-system
                   %immutable-store)))
 
     (users (list (user-account
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 0971ec29e2..b8a30c0abc 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -77,6 +77,9 @@ the derivations referenced by EXP are automatically copied to the initrd."
     (program-file "init" exp #:guile guile))
 
   (define builder
+    ;; Do not use "guile-zlib" extension here, otherwise it would drag the
+    ;; non-static "zlib" package to the initrd closure.  It is not needed
+    ;; anyway because the modules are stored uncompressed within the initrd.
     (with-imported-modules (source-module-closure
                             '((gnu build linux-initrd)))
       #~(begin
@@ -111,34 +114,49 @@ the derivations referenced by EXP are automatically copied to the initrd."
 (define (flat-linux-module-directory linux modules)
   "Return a flat directory containing the Linux kernel modules listed in
 MODULES and taken from LINUX."
-  (define build-exp
-    (with-imported-modules (source-module-closure
-                            '((gnu build linux-modules)))
-      #~(begin
-          (use-modules (gnu build linux-modules)
-                       (srfi srfi-1)
-                       (srfi srfi-26))
-
-          (define module-dir
-            (string-append #$linux "/lib/modules"))
+  (define imported-modules
+    (source-module-closure '((gnu build linux-modules)
+                             (guix build utils))))
 
-          (define modules
-            (let* ((lookup  (cut find-module-file module-dir <>))
-                   (modules (map lookup '#$modules)))
-              (append modules
-                      (recursive-module-dependencies modules
-                                                     #:lookup-module lookup))))
-
-          (mkdir #$output)
-          (for-each (lambda (module)
-                      (format #t "copying '~a'...~%" module)
-                      (copy-file module
-                                 (string-append #$output "/"
-                                                (basename module))))
-                    (delete-duplicates modules))
-
-          ;; Hyphen or underscore?  This database tells us.
-          (write-module-name-database #$output))))
+  (define build-exp
+    (with-imported-modules imported-modules
+      (with-extensions (list guile-zlib)
+        #~(begin
+            (use-modules (gnu build linux-modules)
+                         (guix build utils)
+                         (srfi srfi-1)
+                         (srfi srfi-26))
+
+            (define module-dir
+              (string-append #$linux "/lib/modules"))
+
+            (define modules
+              (let* ((lookup  (cut find-module-file module-dir <>))
+                     (modules (map lookup '#$modules)))
+                (append modules
+                        (recursive-module-dependencies
+                         modules
+                         #:lookup-module lookup))))
+
+            (define (maybe-uncompress file)
+              ;; If FILE is a compressed module, uncompress it, as the initrd
+              ;; is already gzipped as a whole.
+              (cond
+               ((string-contains file ".ko.gz")
+                (invoke #+(file-append gzip "/bin/gunzip") file))))
+
+            (mkdir #$output)
+            (for-each (lambda (module)
+                        (let ((out-module
+                               (string-append #$output "/"
+                                              (basename module))))
+                          (format #t "copying '~a'...~%" module)
+                          (copy-file module out-module)
+                          (maybe-uncompress out-module)))
+                      (delete-duplicates modules))
+
+            ;; Hyphen or underscore?  This database tells us.
+            (write-module-name-database #$output)))))
 
   (computed-file "linux-modules" build-exp))
 
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index c3f98302ad..31c50c4e40 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -23,8 +23,9 @@
   #:use-module (guix records)
   #:use-module ((guix modules) #:hide (file-name->module-name))
   #:use-module (guix i18n)
-  #:use-module ((guix utils)
+  #:use-module ((guix diagnostics)
                 #:select (source-properties->location
+                          formatted-message
                           &fix-hint
                           &error-location))
   #:use-module (gnu services)
@@ -132,13 +133,13 @@ DEVICE must be a \"/dev\" file name."
     ;; "usb_storage"), not file names (e.g., "usb-storage.ko").  This is
     ;; OK because we have machinery that accepts both the hyphen and the
     ;; underscore version.
-    (raise (condition
-            (&message
-             (message (format #f (G_ "you may need these modules \
+    (raise (make-compound-condition
+            (formatted-message (G_ "you may need these modules \
 in the initrd for ~a:~{ ~a~}")
-                              device missing)))
-            (&fix-hint
-             (hint (format #f (G_ "Try adding them to the
+                               device missing)
+            (condition
+             (&fix-hint
+              (hint (format #f (G_ "Try adding them to the
 @code{initrd-modules} field of your @code{operating-system} declaration, along
 these lines:
 
@@ -151,9 +152,10 @@ these lines:
 
 If you think this diagnostic is inaccurate, use the @option{--skip-checks}
 option of @command{guix system}.\n")
-                           missing)))
-            (&error-location
-             (location (source-properties->location location)))))))
+                            missing))))
+            (condition
+             (&error-location
+              (location (source-properties->location location))))))))
 
 
 ;;;
@@ -215,13 +217,13 @@ option of @command{guix system}.\n")
         (if (uuid? source)
             (match (find-partition-by-luks-uuid (uuid-bytevector source))
               (#f
-               (raise (condition
-                       (&message
-                        (message (format #f (G_ "no LUKS partition with UUID '~a'")
-                                         (uuid->string source))))
-                       (&error-location
-                        (location (source-properties->location
-                                   (mapped-device-location md)))))))
+               (raise (make-compound-condition
+                       (formatted-message (G_ "no LUKS partition with UUID '~a'")
+                                          (uuid->string source))
+                       (condition
+                        (&error-location
+                         (location (source-properties->location
+                                    (mapped-device-location md))))))))
               ((? string? device)
                (check-device-initrd-modules device initrd-modules location)))
             (check-device-initrd-modules source initrd-modules location)))))
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index bc3af69610..c8352f4933 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -45,6 +45,7 @@
             string->btrfs-uuid
             string->fat-uuid
             string->jfs-uuid
+            string->ntfs-uuid
             iso9660-uuid->string
 
             ;; XXX: For lack of a better place.
@@ -197,6 +198,38 @@ ISO9660 UUID representation."
 
 
 ;;;
+;;; NTFS.
+;;;
+
+(define-syntax %ntfs-endianness
+  ;; Endianness of NTFS file system.
+  (identifier-syntax (endianness little)))
+
+(define (ntfs-uuid->string uuid)
+  "Convert NTFS UUID, a 8-byte bytevector, to its string representation."
+  (format #f "~{~:@(~x~)~}" (reverse (bytevector->u8-list uuid))))
+
+(define %ntfs-uuid-rx
+  (make-regexp "^([[:xdigit:]]{16})$"))
+
+(define (string->ntfs-uuid str)
+  "Parse STR, which is in NTFS format, and return a bytevector or #f."
+  (match (regexp-exec %ntfs-uuid-rx str)
+    (#f
+     #f)
+    (rx-match
+     (u8-list->bytevector
+      (let loop ((str str)
+                 (res '()))
+        (if (string=? str "")
+            res
+            (loop (string-drop str 2)
+                  (cons
+                   (string->number (string-take str 2) 16)
+                   res))))))))
+
+
+;;;
 ;;; Generic interface.
 ;;;
 
@@ -220,13 +253,15 @@ ISO9660 UUID representation."
   (vhashq
    ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => string->dce-uuid)
    ('fat32 'fat16 'fat => string->fat-uuid)
+   ('ntfs => string->ntfs-uuid)
    ('iso9660 => string->iso9660-uuid)))
 
 (define %uuid-printers
   (vhashq
    ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => dce-uuid->string)
    ('iso9660 => iso9660-uuid->string)
-   ('fat32 'fat16 'fat => fat-uuid->string)))
+   ('fat32 'fat16 'fat => fat-uuid->string)
+   ('ntfs => ntfs-uuid->string)))
 
 (define* (string->uuid str #:optional (type 'dce))
   "Parse STR as a UUID of the given TYPE.  On success, return the
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 861f2a427a..80a8618729 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -699,7 +699,8 @@ of the GNU system as described by OS."
        (device (file-system->mount-tag source))
        (type "9p")
        (flags (if writable? '() '(read-only)))
-       (options "trans=virtio,cache=loose")
+       (options (string-append "trans=virtio"
+                               (if writable? "" ",cache=loose")))
        (check? #f)
        (create-mount-point? #t)))))