05/07: system: image: Add tarball support.

[guix-commits]

mothacehe pushed a commit to branch wip-image
in repository guix.

commit 30292f4990d7689d3b58e786affbda7ce9a9287e
Author: Alex Griffin <a@ajgrf.com>
AuthorDate: Sun Feb 6 16:29:47 2022 -0600

    system: image: Add tarball support.
    
    * gnu/image.scm (<image>)[fields]: Add tarball to the supported formats.
    * gnu/system/image.scm (tarball-image, tarball-image-type): New variables.
    (system-tarball-image): New procedure.
    (image->root-file-system): Add tarball image support.
    (system-image): Ditto.
    * doc/guix.texi ("System Images"): Document it.
    
    Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
---
 doc/guix.texi        |  2 ++
 gnu/image.scm        |  2 +-
 gnu/system/image.scm | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 84 insertions(+), 2 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 6983c1ae79..22e22ee041 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -41330,6 +41330,8 @@ one or multiple partitions.
 
 @item @code{iso9660}, an ISO-9660 image.
 
+@item @code{tarball}, a tar.gz image archive.
+
 @end itemize
 
 @item @code{platform} (default: @code{#false})
diff --git a/gnu/image.scm b/gnu/image.scm
index 68784deb12..b2ef0f60af 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -152,7 +152,7 @@ that is not in SET, mentioning FIELD in the error message."
 
 ;; The supported image formats.
 (define-set-sanitizer validate-image-format format
-  (disk-image compressed-qcow2 docker iso9660))
+  (disk-image compressed-qcow2 docker iso9660 tarball))
 
 ;; The supported partition table types.
 (define-set-sanitizer validate-partition-table-type partition-table-type
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 709c3ab6ff..5fe123e248 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.
 ;;;
@@ -20,6 +21,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu system image)
+  #:use-module (guix compression)
   #:use-module (guix diagnostics)
   #:use-module (guix discovery)
   #:use-module (guix gexp)
@@ -74,6 +76,7 @@
             efi-disk-image
             iso9660-image
             docker-image
+            tarball-image
             raw-with-offset-disk-image
 
             image-with-os
@@ -83,6 +86,7 @@
             iso-image-type
             uncompressed-iso-image-type
             docker-image-type
+            tarball-image-type
             raw-with-offset-image-type
 
             image-with-label
@@ -180,6 +184,10 @@ parent image record."
   (image-without-os
    (format 'docker)))
 
+(define tarball-image
+  (image
+   (format 'tarball)))
+
 (define* (raw-with-offset-disk-image #:optional (offset root-offset))
   (image-without-os
    (format 'disk-image)
@@ -242,6 +250,11 @@ 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 raw-with-offset-image-type
   (image-type
    (name 'raw-with-offset)
@@ -713,6 +726,71 @@ output file."
                                #:substitutable? ,substitutable?))))
 
 
+;;
+;; Tarball image.
+;;
+
+(define* (system-tarball-image image
+                               #:key
+                               (name "image")
+                               (compressor (srfi-1:first %compressors)))
+  "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"))
+    (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
+                  (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.
 ;;
@@ -721,7 +799,7 @@ output file."
   "Return the IMAGE root partition file-system type."
   (case (image-format image)
     ((iso9660) "iso9660")
-    ((docker) "dummy")
+    ((docker tarball) "dummy")
     (else
      (partition-file-system (find-root-partition image)))))
 
@@ -858,6 +936,8 @@ 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 '(iso9660))
          (system-iso9660-image
           image*