Merge branch 'master' into core-updates

Change-Id: Ide7e5cf1c651f193994c02305b6baa4bea4e165f

4 files changed, 155 insertions, 73 deletions

diff --git a/gnu/system/hurd.scm b/gnu/system/hurd.scm
index 3b138bef65..cbe0081382 100644
--- a/gnu/system/hurd.scm
+++ b/gnu/system/hurd.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020, 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -70,7 +70,7 @@
   ;; Note: the Shepherd comes before the Hurd, not just because its duty is to
   ;; shepherd the herd, but also because we want its 'halt' and 'reboot'
   ;; commands to take precedence.
-  (list shepherd-0.8 hurd netdde bash coreutils file findutils grep sed
+  (list shepherd-0.10 hurd netdde bash coreutils file findutils grep sed
         diffutils patch gawk tar gzip bzip2 xz lzip
         guile-3.0-latest guile-colorized guile-readline
         net-base nss-certs inetutils less procps shadow sudo which
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index b825892232..2cc1012893 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
 ;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -686,7 +687,8 @@ returns an image record where the first partition's label is set to <label>."
 
 (define* (system-docker-image image
                               #:key
-                              (name "docker-image"))
+                              (name "docker-image")
+                              (archiver tar))
   "Build a docker image for IMAGE.  NAME is the base name to use for the
 output file."
   (define boot-program
@@ -731,6 +733,7 @@ output file."
               (use-modules (guix docker)
                            (guix build utils)
                            (gnu build image)
+                           (srfi srfi-1)
                            (srfi srfi-19)
                            (guix build store-copy)
                            (guix store database))
@@ -754,18 +757,30 @@ output file."
                                            #:register-closures? #$register-closures?
                                            #:deduplicate? #f
                                            #:system-directory #$os)
-                (build-docker-image
-                 #$output
-                 (cons* image-root
-                        (map store-info-item
-                             (call-with-input-file #$graph
-                               read-reference-graph)))
-                 #$os
-                 #:entry-point '(#$boot-program #$os)
-                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
-                 #:creation-time (make-time time-utc 0 1)
-                 #:system #$image-target
-                 #:transformations `((,image-root -> ""))))))))
+                (when #$(image-max-layers image)
+                  (setenv "PATH"
+                          (string-join (list #+(file-append archiver "/bin")
+                                             #+(file-append gzip "/bin"))
+                                       ":")))
+                (apply build-docker-image
+                       (append (list #$output
+                                     (append (if #$(image-max-layers image)
+                                                 '()
+                                                 (list image-root))
+                                             (map store-info-item
+                                                  (call-with-input-file #$graph
+                                                    read-reference-graph)))
+                                     #$os
+                                     #:entry-point '(#$boot-program #$os)
+                                     #:compressor
+                                     '(#+(file-append gzip "/bin/gzip") "-9n")
+                                     #:creation-time (make-time time-utc 0 1)
+                                     #:system #$image-target
+                                     #:transformations `((,image-root -> "")))
+                               (if #$(image-max-layers image)
+                                   (list #:root-system image-root
+                                         #:max-layers #$(image-max-layers image))
+                                   '()))))))))
 
     (computed-file name builder
                    ;; Allow offloading so that this I/O-intensive process
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index e6b8970c12..c19a818453 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -64,6 +65,7 @@
             check-device-initrd-modules           ;XXX: needs a better place
 
             luks-device-mapping
+            luks-device-mapping-with-options
             raid-device-mapping
             lvm-device-mapping))
 
@@ -188,7 +190,7 @@ option of @command{guix system}.\n")
 ;;; Common device mappings.
 ;;;
 
-(define (open-luks-device source targets)
+(define* (open-luks-device source targets #:key key-file)
   "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
 'cryptsetup'."
   (with-imported-modules (source-module-closure
@@ -198,7 +200,8 @@ option of @command{guix system}.\n")
       ((target)
        #~(let ((source #$(if (uuid? source)
                              (uuid-bytevector source)
-                             source)))
+                             source))
+               (keyfile #$key-file))
            ;; XXX: 'use-modules' should be at the top level.
            (use-modules (rnrs bytevectors) ;bytevector?
                         ((gnu build file-systems)
@@ -215,29 +218,35 @@ option of @command{guix system}.\n")
            ;; 'cryptsetup open' requires standard input to be a tty to allow
            ;; for interaction but shepherd sets standard input to /dev/null;
            ;; thus, explicitly request a tty.
-           (zero? (system*/tty
-                   #$(file-append cryptsetup-static "/sbin/cryptsetup")
-                   "open" "--type" "luks"
-
-                   ;; Note: We cannot use the "UUID=source" syntax here
-                   ;; because 'cryptsetup' implements it by searching the
-                   ;; udev-populated /dev/disk/by-id directory but udev may
-                   ;; be unavailable at the time we run this.
-                   (if (bytevector? source)
-                       (or (let loop ((tries-left 10))
-                             (and (positive? tries-left)
-                                  (or (find-partition-by-luks-uuid source)
-                                      ;; If the underlying partition is
-                                      ;; not found, try again after
-                                      ;; waiting a second, up to ten
-                                      ;; times.  FIXME: This should be
-                                      ;; dealt with in a more robust way.
-                                      (begin (sleep 1)
-                                             (loop (- tries-left 1))))))
-                           (error "LUKS partition not found" source))
-                       source)
-
-                   #$target)))))))
+           (let ((partition
+                  ;; Note: We cannot use the "UUID=source" syntax here
+                  ;; because 'cryptsetup' implements it by searching the
+                  ;; udev-populated /dev/disk/by-id directory but udev may
+                  ;; be unavailable at the time we run this.
+                  (if (bytevector? source)
+                      (or (let loop ((tries-left 10))
+                            (and (positive? tries-left)
+                                 (or (find-partition-by-luks-uuid source)
+                                     ;; If the underlying partition is
+                                     ;; not found, try again after
+                                     ;; waiting a second, up to ten
+                                     ;; times.  FIXME: This should be
+                                     ;; dealt with in a more robust way.
+                                     (begin (sleep 1)
+                                            (loop (- tries-left 1))))))
+                          (error "LUKS partition not found" source))
+                      source)))
+             ;; We want to fallback to the password unlock if the keyfile fails.
+             (or (and keyfile
+                      (zero? (system*/tty
+                              #$(file-append cryptsetup-static "/sbin/cryptsetup")
+                              "open" "--type" "luks"
+                              "--key-file" keyfile
+                              partition #$target)))
+                 (zero? (system*/tty
+                         #$(file-append cryptsetup-static "/sbin/cryptsetup")
+                         "open" "--type" "luks"
+                         partition #$target)))))))))
 
 (define (close-luks-device source targets)
   "Return a gexp that closes TARGET, a LUKS device."
@@ -276,6 +285,14 @@ option of @command{guix system}.\n")
    (close close-luks-device)
    (check check-luks-device)))
 
+(define* (luks-device-mapping-with-options #:key key-file)
+  "Return a luks-device-mapping object with open modified to pass the arguments
+into the open-luks-device procedure."
+  (mapped-device-kind
+   (inherit luks-device-mapping)
+   (open (λ (source targets) (open-luks-device source targets
+                                               #:key-file key-file)))))
+
 (define (open-raid-device sources targets)
   "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
 TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index 47f19551b6..8b3958ba5c 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -64,6 +64,13 @@
                user-group-system?)
 
   #:export (%default-bashrc
+            %default-bash-profile
+            %default-zprofile
+            %default-xdefaults
+            %default-gdbinit
+            %default-nanorc
+            %default-dotguile
+            %default-skeleton-home-config
             default-skeletons
             skeleton-directory
             %base-groups
@@ -147,11 +154,8 @@ alias ll='ls -l'
 alias grep='grep --color=auto'
 alias ip='ip -color=auto'\n"))
 
-(define (default-skeletons)
-  "Return the default skeleton files for /etc/skel.  These files are copied by
-'useradd' in the home directory of newly created user accounts."
-
-  (let ((profile (plain-file "bash_profile" "\
+(define %default-bash-profile
+  (plain-file "bash_profile" "\
 # Set up Guix Home profile
 if [ -f ~/.profile ]; then . ~/.profile; fi
 
@@ -167,25 +171,23 @@ eval \"$(guix package --search-paths \\
 # Prepend setuid programs.
 export PATH=/run/setuid-programs:$PATH
 "))
-        (bashrc  %default-bashrc)
-        (zprofile    (plain-file "zprofile" "\
-# Honor system-wide environment variables
-source /etc/profile
-
-# Merge search-paths from multiple profiles, the order matters.
-eval \"$(guix package --search-paths \\
--p $HOME/.config/guix/current \\
--p $HOME/.guix-profile \\
--p /run/current-system/profile)\"
 
-# Prepend setuid programs.
-export PATH=/run/setuid-programs:$PATH
+(define %default-zprofile
+  (plain-file "zprofile" "\
+# Set up the system, user profile, and related variables.
+source /etc/profile
+# Set up the home environment profile.
+source ~/.profile
 "))
-        (xdefaults (plain-file "Xdefaults" "\
+
+(define %default-xdefaults
+  (plain-file "Xdefaults" "\
 XTerm*utf8: always
 XTerm*metaSendsEscape: true\n"))
-        (gdbinit   (plain-file "gdbinit" "\
-# Tell GDB where to look for separate debugging files.
+
+(define %default-gdbinit
+  (plain-file "gdbinit"
+              "# Tell GDB where to look for separate debugging files.
 guile
 (use-modules (gdb))
 (execute (string-append \"set debug-file-directory \"
@@ -203,19 +205,16 @@ end
 
 # Authorize extensions found in the store, such as the
 # pretty-printers of libstdc++.
-set auto-load safe-path /gnu/store/*/lib\n")))
-    `((".bash_profile" ,profile)
-      (".bashrc" ,bashrc)
-      ;; Zsh sources ~/.zprofile before ~/.zshrc, and it sources ~/.zlogin
-      ;; after ~/.zshrc.  To avoid interfering with any customizations a user
-      ;; may have made in their ~/.zshrc, put this in .zprofile, not .zlogin.
-      (".zprofile" ,zprofile)
-      (".nanorc" ,(plain-file "nanorc" "\
-# Include all the syntax highlighting modules.
+set auto-load safe-path /gnu/store/*/lib\n"))
+
+(define %default-nanorc
+  (plain-file "nanorc"
+              "# Include all the syntax highlighting modules.
 include /run/current-system/profile/share/nano/*.nanorc\n"))
-      (".Xdefaults" ,xdefaults)
-      (".guile" ,(plain-file "dot-guile"
-                             "(cond ((false-if-exception (resolve-interface '(ice-9 readline)))
+
+(define %default-dotguile
+  (plain-file "dot-guile"
+              "(cond ((false-if-exception (resolve-interface '(ice-9 readline)))
        =>
        (lambda (module)
          ;; Enable completion and input history at the REPL.
@@ -233,7 +232,58 @@ convenient interactive line editing and input history.\\n\\n\")))
               (else
                (display \"Consider installing the 'guile-colorized' package
 for a colorful Guile experience.\\n\\n\"))))\n"))
-      (".gdbinit" ,gdbinit))))
+
+(define %default-skeleton-home-config
+  (plain-file "default-home-config" "\
+;; This is a sample Guix Home configuration which can help setup your
+;; home directory in the same declarative manner as Guix System.
+;; For more information, see the Home Configuration section of the manual.
+(define-module (guix-home-config)
+  #:use-module (gnu home)
+  #:use-module (gnu home services)
+  #:use-module (gnu home services shells)
+  #:use-module (gnu services)
+  #:use-module (gnu system shadow))
+
+(define home-config
+  (home-environment
+    (services
+      (list
+        ;; Uncomment the shell you wish to use for your user:
+        ;(service home-bash-service-type)
+        ;(service home-fish-service-type)
+        ;(service home-zsh-service-type)
+
+        (service home-files-service-type
+         `((\".guile\" ,%default-dotguile)
+           (\".Xdefaults\" ,%default-xdefaults)))
+
+        (service home-xdg-configuration-files-service-type
+         `((\"gdb/gdbinit\" ,%default-gdbinit)
+           (\"nano/nanorc\" ,%default-nanorc)))))))
+
+home-config"))
+
+(define (default-skeletons)
+  "Return the default skeleton files for /etc/skel.  These files are copied by
+'useradd' in the home directory of newly created user accounts."
+
+  (let ((profile   %default-bash-profile)
+        (bashrc    %default-bashrc)
+        (zprofile  %default-zprofile)
+        (xdefaults %default-xdefaults)
+        (gdbinit   %default-gdbinit))
+    `((".bash_profile" ,profile)
+      (".bashrc" ,bashrc)
+      ;; Zsh sources ~/.zprofile before ~/.zshrc, and it sources ~/.zlogin
+      ;; after ~/.zshrc.  To avoid interfering with any customizations a user
+      ;; may have made in their ~/.zshrc, put this in .zprofile, not .zlogin.
+      (".zprofile" ,zprofile)
+      (".nanorc" ,%default-nanorc)
+      (".Xdefaults" ,xdefaults)
+      (".guile" ,%default-dotguile)
+      (".gdbinit" ,gdbinit)
+      ("guix-home-config.scm" ,%default-skeleton-home-config))))
 
 (define (skeleton-directory skeletons)
   "Return a directory containing SKELETONS, a list of name/derivation tuples."