Merge branch 'staging' into core-updates

Conflicts resolved in:
	gnu/local.mk
	gnu/packages/cran.scm
	gnu/packages/gnome.scm
	gnu/packages/gtk.scm
	gnu/packages/icu4c.scm
	gnu/packages/java.scm
	gnu/packages/machine-learning.scm
	gnu/packages/tex.scm

4 files changed, 300 insertions, 11 deletions

diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 464b76a2ca..f2eb2e0837 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -434,7 +434,7 @@ TARGET in the other system."
 (define %pseudo-file-system-types
   ;; List of know pseudo file system types.  This is used when validating file
   ;; system definitions.
-  '("binfmt_misc" "cgroup" "debugfs" "devpts" "devtmpfs" "efivarfs" "fusectl"
+  '("binfmt_misc" "cgroup" "cgroup2" "debugfs" "devpts" "devtmpfs" "efivarfs" "fusectl"
     "hugetlbfs" "overlay" "proc" "securityfs" "sysfs" "tmpfs"))
 
 (define %fuse-control-file-system
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index a04363a130..5fc0d55d9a 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
+;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,17 +33,20 @@
   #:use-module ((guix self) #:select (make-config.scm))
   #:use-module (gnu bootloader)
   #:use-module (gnu bootloader grub)
+  #:use-module (gnu compression)
   #:use-module (gnu image)
   #:use-module (guix platform)
   #:use-module (gnu services)
   #:use-module (gnu services base)
   #:use-module (gnu system)
+  #:use-module (gnu system accounts)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system linux-container)
   #:use-module (gnu system uuid)
   #:use-module (gnu system vm)
   #:use-module (guix packages)
   #:use-module (gnu packages base)
+  #:use-module (gnu packages bash)
   #:use-module (gnu packages bootloaders)
   #:use-module (gnu packages cdrom)
   #:use-module (gnu packages compression)
@@ -65,6 +69,7 @@
   #:use-module (ice-9 match)
   #:export (root-offset
             root-label
+            image-without-os
 
             esp-partition
             esp32-partition
@@ -73,6 +78,8 @@
             efi-disk-image
             iso9660-image
             docker-image
+            tarball-image
+            wsl2-image
             raw-with-offset-disk-image
 
             image-with-os
@@ -82,6 +89,8 @@
             iso-image-type
             uncompressed-iso-image-type
             docker-image-type
+            tarball-image-type
+            wsl2-image-type
             raw-with-offset-image-type
 
             image-with-label
@@ -102,6 +111,12 @@
 ;; Generic root partition label.
 (define root-label "Guix_image")
 
+(define-syntax-rule (image-without-os . fields)
+    "Return an image record with the mandatory operating-system field set to
+#false.  This is useful when creating an image record that will serve as a
+parent image record."
+   (image (operating-system #false) . fields))
+
 (define esp-partition
   (partition
    (size (* 40 (expt 2 20)))
@@ -127,17 +142,17 @@
    (initializer (gexp initialize-root-partition))))
 
 (define efi-disk-image
-  (image
+  (image-without-os
    (format 'disk-image)
    (partitions (list esp-partition root-partition))))
 
 (define efi32-disk-image
-  (image
+  (image-without-os
    (format 'disk-image)
    (partitions (list esp32-partition root-partition))))
 
 (define iso9660-image
-  (image
+  (image-without-os
    (format 'iso9660)
    (partitions
     (list (partition
@@ -146,11 +161,19 @@
            (flags '(boot)))))))
 
 (define docker-image
-  (image
+  (image-without-os
    (format 'docker)))
 
+(define tarball-image
+  (image-without-os
+   (format 'tarball)))
+
+(define wsl2-image
+  (image-without-os
+   (format 'wsl2)))
+
 (define* (raw-with-offset-disk-image #:optional (offset root-offset))
-  (image
+  (image-without-os
    (format 'disk-image)
    (partitions
     (list (partition
@@ -211,6 +234,16 @@ set to the given OS."
    (name 'docker)
    (constructor (cut image-with-os docker-image <>))))
 
+(define tarball-image-type
+  (image-type
+   (name 'tarball)
+   (constructor (cut image-with-os tarball-image <>))))
+
+(define wsl2-image-type
+  (image-type
+   (name 'wsl2)
+   (constructor (cut image-with-os wsl2-image <>))))
+
 (define raw-with-offset-image-type
   (image-type
    (name 'raw-with-offset)
@@ -682,6 +715,88 @@ output file."
                                #:substitutable? ,substitutable?))))
 
 
+;;;
+;;; Tarball image.
+;;;
+
+;; TODO: Some bits can be factorized with (guix scripts pack).
+(define* (system-tarball-image image
+                               #:key
+                               (name "image")
+                               (compressor (srfi-1:first %compressors))
+                               (wsl? #f))
+  "Build a tarball of IMAGE.  NAME is the base name to use for the
+output file."
+  (let* ((os (image-operating-system image))
+         (substitutable? (image-substitutable? image))
+         (schema (local-file (search-path %load-path
+                                          "guix/store/schema.sql")))
+         (name (string-append name ".tar" (compressor-extension compressor)))
+         (graph "system-graph")
+         (root (srfi-1:find (lambda (user)
+                              (and=> (user-account-uid user) zero?))
+                            (operating-system-users os)))
+         (root-shell (or (and=> root user-account-shell)
+                         (file-append bash "/bin/bash"))))
+    (define builder
+      (with-extensions gcrypt-sqlite3&co          ;for (guix store database)
+        (with-imported-modules `(,@(source-module-closure
+                                    '((guix build pack)
+                                      (guix build store-copy)
+                                      (guix build utils)
+                                      (guix store database)
+                                      (gnu build image))
+                                    #:select? not-config?)
+                                 ((guix config) => ,(make-config.scm)))
+          #~(begin
+              (use-modules (guix build pack)
+                           (guix build store-copy)
+                           (guix build utils)
+                           (guix store database)
+                           (gnu build image))
+
+              ;; Set the SQL schema location.
+              (sql-schema #$schema)
+
+              ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+              (setenv "GUIX_LOCPATH"
+                      #+(file-append glibc-utf8-locales "/lib/locale"))
+              (setlocale LC_ALL "en_US.utf8")
+
+              (let ((image-root (string-append (getcwd) "/tmp-root"))
+                    (tar #+(file-append tar "/bin/tar")))
+
+                (mkdir-p image-root)
+                (initialize-root-partition image-root
+                                           #:references-graphs '(#$graph)
+                                           #:deduplicate? #f
+                                           #:system-directory #$os)
+
+                (with-directory-excursion image-root
+                  #$@(if wsl?
+                         #~(;; WSL requires /bin/sh.  Will be overwritten by
+                            ;; system activation.
+                            (symlink #$root-shell "./bin/sh")
+
+                            ;; WSL requires /bin/mount to access the host fs.
+                            (symlink #$(file-append util-linux "/bin/mount")
+                                     "./bin/mount"))
+                         #~())
+
+                  (apply invoke tar "-cvf" #$output "."
+                         (tar-base-options
+                          #:tar tar
+                          #:compressor
+                          #+(and=> compressor compressor-command)))))))))
+
+    (computed-file name builder
+                   ;; Allow offloading so that this I/O-intensive process
+                   ;; doesn't run on the build farm's head node.
+                   #:local-build? #f
+                   #:options `(#:references-graphs ((,graph ,os))
+                               #:substitutable? ,substitutable?))))
+
+
 ;;
 ;; Image creation.
 ;;
@@ -690,7 +805,7 @@ output file."
   "Return the IMAGE root partition file-system type."
   (case (image-format image)
     ((iso9660) "iso9660")
-    ((docker) "dummy")
+    ((docker tarball wsl2) "dummy")
     (else
      (partition-file-system (find-root-partition image)))))
 
@@ -827,6 +942,10 @@ image, depending on IMAGE format."
                                        ("bootcfg" ,bootcfg))))
        ((memq image-format '(docker))
         (system-docker-image image*))
+       ((memq image-format '(tarball))
+        (system-tarball-image image*))
+       ((memq image-format '(wsl2))
+        (system-tarball-image image* #:wsl? #t))
        ((memq image-format '(iso9660))
          (system-iso9660-image
           image*
diff --git a/gnu/system/images/hurd.scm b/gnu/system/images/hurd.scm
index 6da09b855a..9b618f7dc6 100644
--- a/gnu/system/images/hurd.scm
+++ b/gnu/system/images/hurd.scm
@@ -74,9 +74,9 @@
                            #:wal-mode? #f)))))
 
 (define hurd-disk-image
-  (image
+  (image-without-os
    (format 'disk-image)
-   (platform hurd)
+   (platform i586-gnu)
    (partitions
     (list (partition
            (size 'guess)
@@ -104,14 +104,14 @@
 (define hurd-barebones-disk-image
   (image
    (inherit
-    (os+platform->image hurd-barebones-os hurd
+    (os+platform->image hurd-barebones-os i586-gnu
                         #:type hurd-image-type))
    (name 'hurd-barebones-disk-image)))
 
 (define hurd-barebones-qcow2-image
   (image
    (inherit
-    (os+platform->image hurd-barebones-os hurd
+    (os+platform->image hurd-barebones-os i586-gnu
                         #:type hurd-qcow2-image-type))
    (name 'hurd-barebones.qcow2)))
 
diff --git a/gnu/system/images/wsl2.scm b/gnu/system/images/wsl2.scm
new file mode 100644
index 0000000000..15cb4f69b8
--- /dev/null
+++ b/gnu/system/images/wsl2.scm
@@ -0,0 +1,170 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.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 images wsl2)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu image)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages bash)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu system)
+  #:use-module (gnu system image)
+  #:use-module (gnu system shadow)
+  #:use-module (guix build-system trivial)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:export (wsl-boot-program
+            wsl-os
+            wsl2-image))
+
+(define (wsl-boot-program user)
+  "Program that runs the system boot script, then starts a login shell as
+USER."
+  (program-file
+   "wsl-boot-program"
+   (with-imported-modules '((guix build syscalls))
+     #~(begin
+         (use-modules (guix build syscalls))
+         (unless (file-exists? "/run/current-system")
+           (let ((shepherd-socket "/var/run/shepherd/socket"))
+             ;; Clean up this file so we can wait for it later.
+             (when (file-exists? shepherd-socket)
+               (delete-file shepherd-socket))
+
+             ;; Child process boots the system and is replaced by shepherd.
+             (when (zero? (primitive-fork))
+               (let* ((system-generation
+                       (readlink "/var/guix/profiles/system"))
+                      (system (readlink
+                               (string-append
+                                (if (absolute-file-name? system-generation)
+                                    ""
+                                    "/var/guix/profiles/")
+                                system-generation))))
+                 (setenv "GUIX_NEW_SYSTEM" system)
+                 (execl #$(file-append guile-3.0 "/bin/guile")
+                        "guile"
+                        "--no-auto-compile"
+                        (string-append system "/boot"))))
+
+             ;; Parent process waits for shepherd before continuing.
+             (while (not (file-exists? shepherd-socket))
+               (sleep 1))))
+
+         (let* ((pw (getpw #$user))
+                (shell (passwd:shell pw))
+                (sudo #+(file-append sudo "/bin/sudo"))
+                (args (cdr (command-line))))
+           ;; Save the value of $PATH set by WSL.  Useful for finding
+           ;; Windows binaries to run with WSL's binfmt interop.
+           (setenv "WSLPATH" (getenv "PATH"))
+
+           ;; /run is mounted with the nosuid flag by WSL.  This prevents
+           ;; running the /run/setuid-programs.  Remount it without this flag
+           ;; as a workaround.  See:
+           ;; https://github.com/microsoft/WSL/issues/8716.
+           (mount #f "/run" #f
+                  MS_REMOUNT
+                  #:update-mtab? #f)
+
+           ;; Start login shell as user.
+           (apply execl sudo "sudo"
+                  "--preserve-env=WSLPATH"
+                  "-u" #$user
+                  "--"
+                  shell "-l" args))))))
+
+(define dummy-package
+  (package
+    (name "dummy")
+    (version "0")
+    (source #f)
+    (build-system trivial-build-system)
+    (arguments
+     `(#:modules ((guix build utils))
+       #:target #f
+       #:builder (begin
+                   (use-modules (guix build utils))
+                   (let* ((out (assoc-ref %outputs "out"))
+                          (dummy (string-append out "/dummy")))
+                     (mkdir-p out)
+                     (call-with-output-file dummy
+                       (const #t))))))
+    (home-page #f)
+    (synopsis #f)
+    (description #f)
+    (license #f)))
+
+(define dummy-bootloader
+  (bootloader
+   (name 'dummy-bootloader)
+   (package dummy-package)
+   (configuration-file "/dev/null")
+   (configuration-file-generator
+    (lambda (. _rest)
+      (plain-file "dummy-bootloader" "")))
+   (installer #~(const #t))))
+
+(define dummy-kernel dummy-package)
+
+(define (dummy-initrd . _rest)
+  (plain-file "dummy-initrd" ""))
+
+(define-public wsl-os
+  (operating-system
+    (host-name "gnu")
+    (timezone "Etc/UTC")
+    (bootloader
+     (bootloader-configuration
+      (bootloader dummy-bootloader)))
+    (kernel dummy-kernel)
+    (initrd dummy-initrd)
+    (initrd-modules '())
+    (firmware '())
+    (file-systems '())
+    (users (cons* (user-account
+                   (name "guest")
+                   (group "users")
+                   (supplementary-groups '("wheel")) ; allow use of sudo
+                   (password "")
+                   (comment "Guest of GNU"))
+                  (user-account
+                   (inherit %root-account)
+                   (shell (wsl-boot-program "guest")))
+                  %base-user-accounts))
+    (services
+     (list
+      (service guix-service-type)
+      (service special-files-service-type
+               `(("/bin/sh" ,(file-append bash "/bin/bash"))
+                 ("/bin/mount" ,(file-append util-linux "/bin/mount"))
+                 ("/usr/bin/env" ,(file-append coreutils "/bin/env"))))))))
+
+(define wsl2-image
+  (image
+   (inherit
+    (os->image wsl-os
+               #:type wsl2-image-type))
+   (name 'wsl2-image)))
+
+wsl2-image