From 27304913a968753f42d06eb2ae7c297873b77cb6 Mon Sep 17 00:00:00 2001
From: Alex Griffin <a@ajgrf.com>
Date: Mon, 7 Feb 2022 18:37:25 -0600
Subject: [PATCH 3/5] system: image: Add wsl-tarball support.

* gnu/system/image.scm (wsl-tarball-image, wsl-tarball-image-type): New variables.
(image->root-file-system): Add wsl-tarball image support.
(system-image): Ditto.
---
 gnu/system/image.scm | 36 +++++++++++++++++++++++++++++++++---
 1 file changed, 33 insertions(+), 3 deletions(-)

diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 33c9c23225..83a2a76a9c 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -37,12 +37,14 @@ (define-module (gnu system image)
   #: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)
@@ -73,6 +75,7 @@ (define-module (gnu system image)
             iso9660-image
             docker-image
             tarball-image
+            wsl-tarball-image
             raw-with-offset-disk-image
 
             image-with-os
@@ -82,6 +85,7 @@ (define-module (gnu system image)
             uncompressed-iso-image-type
             docker-image-type
             tarball-image-type
+            wsl-tarball-image-type
             raw-with-offset-image-type
 
             image-with-label
@@ -143,6 +147,10 @@ (define tarball-image
   (image
    (format 'tarball)))
 
+(define wsl-tarball-image
+  (image
+   (format 'wsl-tarball)))
+
 (define* (raw-with-offset-disk-image #:optional (offset root-offset))
   (image
    (format 'disk-image)
@@ -205,6 +213,11 @@ (define tarball-image-type
    (name 'tarball)
    (constructor (cut image-with-os tarball-image <>))))
 
+(define wsl-tarball-image-type
+  (image-type
+   (name 'wsl-tarball)
+   (constructor (cut image-with-os wsl-tarball-image <>))))
+
 (define raw-with-offset-image-type
   (image-type
    (name 'raw-with-offset)
@@ -652,7 +665,8 @@ (define builder
 (define* (system-tarball-image image
                                #:key
                                (name "image")
-                               (compressor (srfi-1:first %compressors)))
+                               (compressor (srfi-1:first %compressors))
+                               (wsl? #f))
   "Build a tarball of IMAGE.  NAME is the base name to use for the
 output file."
   (let* ((shared-network? (image-shared-network? image))
@@ -661,7 +675,12 @@ (define* (system-tarball-image image
          (schema (local-file (search-path %load-path
                                           "guix/store/schema.sql")))
          (name (string-append name ".tar" (compressor-extension compressor)))
-         (graph "system-graph"))
+         (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
@@ -697,6 +716,15 @@ (define builder
                                            #:system-directory #$os)
 
                 (with-directory-excursion image-root
+                  (when #$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
@@ -718,7 +746,7 @@ (define (image->root-file-system image)
   "Return the IMAGE root partition file-system type."
   (case (image-format image)
     ((iso9660) "iso9660")
-    ((docker tarball) "dummy")
+    ((docker tarball wsl-tarball) "dummy")
     (else
      (partition-file-system (find-root-partition image)))))
 
@@ -858,6 +886,8 @@ (define target (cond
         (system-docker-image image*))
        ((memq image-format '(tarball))
         (system-tarball-image image*))
+       ((memq image-format '(wsl-tarball))
+        (system-tarball-image image* #:wsl? #t))
        ((memq image-format '(iso9660))
          (system-iso9660-image
           image*
-- 
2.34.0