Merge branch 'staging' into core-updates

4 files changed, 98 insertions, 33 deletions

diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl
index ccb0b045db..d46a27978c 100644
--- a/gnu/system/examples/vm-image.tmpl
+++ b/gnu/system/examples/vm-image.tmpl
@@ -43,7 +43,9 @@ accounts.\x1b[0m
   (keyboard-layout (keyboard-layout "us" "altgr-intl"))
 
   ;; Label for the GRUB boot menu.
-  (label (string-append "GNU Guix " (package-version guix)))
+  (label (string-append "GNU Guix "
+                        (or (getenv "GUIX_DISPLAYED_VERSION")
+                            (package-version guix))))
 
   (firmware '())
 
@@ -123,7 +125,14 @@ root ALL=(ALL) ALL
                      (login-service-type config =>
                                          (login-configuration
                                           (inherit config)
-                                          (motd vm-image-motd)))))))
+                                          (motd vm-image-motd)))
+
+                     ;; Install and run the current Guix rather than an older
+                     ;; snapshot.
+                     (guix-service-type config =>
+                                        (guix-configuration
+                                         (inherit config)
+                                         (guix (current-guix))))))))
 
   ;; Allow resolution of '.local' host names with mDNS.
   (name-service-switch %mdns-host-lookup-nss))
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index f8f4276283..464b76a2ca 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -121,7 +122,8 @@
     ;; Note: Keep in sync with 'mount-flags->bit-mask'.
     (let ((known-flags '(read-only
                          bind-mount no-suid no-dev no-exec
-                         no-atime strict-atime lazy-time)))
+                         no-atime strict-atime lazy-time
+                         shared)))
       (lambda (flags)
         "Return the subset of FLAGS that is invalid."
         (remove (cut memq <> known-flags) flags))))
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index a3646b1d54..a7b7c246bf 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -357,11 +357,17 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
            ;; network.  It can be faster than fetching from remote servers.
            (service avahi-service-type)
 
-           ;; The build daemon.  Register the default substitute server key(s)
-           ;; as trusted to allow the installation process to use substitutes by
-           ;; default.
+           ;; The build daemon.
            (service guix-service-type
-                    (guix-configuration (authorize-key? #t)))
+                    (guix-configuration
+                     ;; Register the default substitute server key(s) as
+                     ;; trusted to allow the installation process to use
+                     ;; substitutes by default.
+                     (authorize-key? #t)
+
+                     ;; Install and run the current Guix rather than an older
+                     ;; snapshot.
+                     (guix (current-guix))))
 
            ;; Start udev so that useful device nodes are available.
            ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for
@@ -463,7 +469,8 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
                  (bootloader grub-bootloader)
                  (targets '("/dev/sda"))))
     (label (string-append "GNU Guix installation "
-                          (package-version guix)))
+                          (or (getenv "GUIX_DISPLAYED_VERSION")
+                              (package-version guix))))
 
     ;; XXX: The AMD Radeon driver is reportedly broken, which makes kmscon
     ;; non-functional:
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index 24077e347a..69080bcacb 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Google LLC
+;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -202,16 +203,49 @@ that will be shared with the host system."
                          (guix build utils)
                          (guix i18n)
                          (guix diagnostics)
-                         (srfi srfi-1))
+                         (srfi srfi-1)
+                         (srfi srfi-37)
+                         (ice-9 match))
 
-            (define file-systems
-              (filter-map (lambda (spec)
-                            (let* ((fs    (spec->file-system spec))
-                                   (flags (file-system-flags fs)))
-                              (and (or (not (memq 'bind-mount flags))
-                                       (file-exists? (file-system-device fs)))
-                                   fs)))
-                          '#$specs))
+            (define (show-help)
+              (display (G_ "Usage: run-container [OPTION ...]
+Run the container with the given options."))
+              (newline)
+              (display (G_ "
+      --share=SPEC       share host file system with read/write access
+                         according to SPEC"))
+              (display (G_ "
+      --expose=SPEC      expose host file system directory as read-only
+                         according to SPEC"))
+              (newline)
+              (display (G_ "
+  -h, --help             display this help and exit"))
+              (newline))
+
+            (define %options
+              ;; Specifications of the command-line options.
+              (list (option '(#\h "help") #f #f
+                            (lambda args
+                              (show-help)
+                              (exit 0)))
+                    (option '("share") #t #f
+                            (lambda (opt name arg result)
+                              (alist-cons 'file-system-mapping
+                                          (specification->file-system-mapping arg #t)
+                                          result)))
+                    (option '("expose") #t #f
+                            (lambda (opt name arg result)
+                              (alist-cons 'file-system-mapping
+                                          (specification->file-system-mapping arg #f)
+                                          result)))))
+
+            (define (parse-options args options)
+              (args-fold args options
+                         (lambda (opt name arg . rest)
+                           (report-error (G_ "~A: unrecognized option~%") name)
+                           (exit 1))
+                         (lambda (op res) (cons op res))
+                         '()))
 
             (define (explain pid)
               ;; XXX: We can't quite call 'bindtextdomain' so there's actually
@@ -225,22 +259,35 @@ that will be shared with the host system."
               (info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
               (newline (guix-warning-port)))
 
-            (call-with-container file-systems
-              (lambda ()
-                (setenv "HOME" "/root")
-                (setenv "TMPDIR" "/tmp")
-                (setenv "GUIX_NEW_SYSTEM" #$os)
-                (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
-                (primitive-load (string-append #$os "/boot")))
-              ;; A range of 65536 uid/gids is used to cover 16 bits worth of
-              ;; users and groups, which is sufficient for most cases.
-              ;;
-              ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
-              #:host-uids 65536
-              #:namespaces (if #$shared-network?
-                               (delq 'net %namespaces)
-                               %namespaces)
-              #:process-spawned-hook explain))))
+            (let* ((opts (parse-options (cdr (command-line)) %options))
+                   (mappings (filter-map (match-lambda
+                                           (('file-system-mapping . mapping) mapping)
+                                           (_ #f))
+                                         opts))
+                   (file-systems
+                    (filter-map (lambda (fs)
+                                  (let ((flags (file-system-flags fs)))
+                                    (and (or (not (memq 'bind-mount flags))
+                                             (file-exists? (file-system-device fs)))
+                                         fs)))
+                                (append (map file-system-mapping->bind-mount mappings)
+                                        (map spec->file-system '#$specs)))))
+              (call-with-container file-systems
+                (lambda ()
+                  (setenv "HOME" "/root")
+                  (setenv "TMPDIR" "/tmp")
+                  (setenv "GUIX_NEW_SYSTEM" #$os)
+                  (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
+                  (primitive-load (string-append #$os "/boot")))
+                ;; A range of 65536 uid/gids is used to cover 16 bits worth of
+                ;; users and groups, which is sufficient for most cases.
+                ;;
+                ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
+                #:host-uids 65536
+                #:namespaces (if #$shared-network?
+                                 (delq 'net %namespaces)
+                                 %namespaces)
+                #:process-spawned-hook explain)))))
 
     (gexp->script "run-container" script)))