diff mbox series

[bug#57680,2/2] system: image: Add tarball support.

Message ID 20220908153033.7016-2-othacehe@gnu.org
State Accepted
Headers show
Series image: Add tarball support. | expand

Checks

Context Check Description
cbaines/comparison success View comparision
cbaines/git-branch success View Git branch
cbaines/applying patch success View Laminar job
cbaines/issue success View issue

Commit Message

Mathieu Othacehe Sept. 8, 2022, 3:30 p.m. UTC
From: Alex Griffin <a@ajgrf.com>

* 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.

Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
---
 gnu/image.scm        |  2 +-
 gnu/system/image.scm | 82 +++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 82 insertions(+), 2 deletions(-)

Comments

Ludovic Courtès Sept. 24, 2022, 1:52 p.m. UTC | #1
Hi,

Mathieu Othacehe <othacehe@gnu.org> skribis:

> From: Alex Griffin <a@ajgrf.com>
>
> * 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.
>
> Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>

Nice!

Perhaps we need to mention it in the manual?

> +;;
> +;; Tarball image.
> +;;

Three semicolons maybe?  :-)

> +(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?))))

There’s probably something to be factorized with (guix scripts pack),
but that can be left for later with a TODO.

Otherwise LGTM, thank you & Alex!

Ludo’.
diff mbox series

Patch

diff --git a/gnu/image.scm b/gnu/image.scm
index 4a0068934e..18e24d3cac 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -152,7 +152,7 @@  (define-with-syntax-properties (name (value properties))
 
 ;; 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 a04363a130..5e50210523 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)
@@ -73,6 +75,7 @@  (define-module (gnu system image)
             efi-disk-image
             iso9660-image
             docker-image
+            tarball-image
             raw-with-offset-disk-image
 
             image-with-os
@@ -82,6 +85,7 @@  (define-module (gnu system image)
             iso-image-type
             uncompressed-iso-image-type
             docker-image-type
+            tarball-image-type
             raw-with-offset-image-type
 
             image-with-label
@@ -149,6 +153,10 @@  (define docker-image
   (image
    (format 'docker)))
 
+(define tarball-image
+  (image
+   (format 'tarball)))
+
 (define* (raw-with-offset-disk-image #:optional (offset root-offset))
   (image
    (format 'disk-image)
@@ -211,6 +219,11 @@  (define docker-image-type
    (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)
@@ -681,6 +694,71 @@  (define builder
                    #:options `(#:references-graphs ((,graph ,os))
                                #: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.
@@ -690,7 +768,7 @@  (define (image->root-file-system image)
   "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)))))
 
@@ -827,6 +905,8 @@  (define target (cond
                                        ("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*