[bug#53912] [PATCH 4/5] system: Add wsl module.

[Alex Griffin via Guix-patches via <guix-patches@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 153 bytes --]

This patch adds a new module at gnu/system/wsl.scm. It contains a
minimal operating-system definition that works in WSL.

Thanks,
–
Alex Griffin

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0004-system-Add-wsl-module.patch --]
[-- Type: text/x-patch; name=0004-system-Add-wsl-module.patch, Size: 6863 bytes --]

From 55cbd67645fced42905b3bcff345116de7365049 Mon Sep 17 00:00:00 2001
From: Alex Griffin <a@ajgrf.com>
Date: Wed, 9 Feb 2022 23:09:52 -0600
Subject: [PATCH 4/5] system: Add wsl module.

* gnu/system/wsl.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk       |   2 +
 gnu/system/wsl.scm | 148 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 150 insertions(+)
 create mode 100644 gnu/system/wsl.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 198c8f64a6..fecde5b4dd 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -49,6 +49,7 @@
 # Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 # Copyright © 2022 Daniel Meißner <daniel.meissner-i4k@ruhr-uni-bochum.de>
 # Copyright © 2022 Remco van 't Veer <remco@remworks.net>
+# Copyright © 2022 Alex Griffin <a@ajgrf.com>
 #
 # This file is part of GNU Guix.
 #
@@ -700,6 +701,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/system/shadow.scm				\
   %D%/system/uuid.scm				\
   %D%/system/vm.scm				\
+  %D%/system/wsl.scm				\
 						\
   %D%/system/images/hurd.scm			\
   %D%/system/images/novena.scm			\
diff --git a/gnu/system/wsl.scm b/gnu/system/wsl.scm
new file mode 100644
index 0000000000..63c71926a7
--- /dev/null
+++ b/gnu/system/wsl.scm
@@ -0,0 +1,148 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;;
+;;; 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 wsl)
+  #:use-module (gnu bootloader)
+  #: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 shadow)
+  #:use-module (guix build-system trivial)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:export (wsl-boot-program
+            wsl-os))
+
+(define (wsl-boot-program user)
+  "Program that runs the system boot script, then starts a login shell as USER."
+  (program-file
+   "wsl-boot-program"
+   #~(begin
+       (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"))
+
+         ;; 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))
+                     #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"))))))))
-- 
2.34.0