[bug#53912,2/5] system: image: Add tarball support.
Commit Message
This patch adds support for generating a tarball from operating-system definitions.
--
Alex Griffin
Comments
Hi,
Alex Griffin <a@ajgrf.com> skribis:
> From ef951ff51bf0e2b2b50c57fbf652b0677c1e6701 Mon Sep 17 00:00:00 2001
> From: Alex Griffin <a@ajgrf.com>
> Date: Sun, 6 Feb 2022 16:29:47 -0600
> Subject: [PATCH 2/5] system: image: Add tarball support.
>
> * 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.
Interesting!
> +++ b/gnu/system/image.scm
> @@ -1,6 +1,7 @@
> ;;; GNU Guix --- Functional package management for GNU
> ;;; Copyright © 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com>
> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
> +;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
> ;;;
> ;;; This file is part of GNU Guix.
> ;;;
> @@ -24,6 +25,7 @@ (define-module (gnu system image)
> #:use-module (guix modules)
> #:use-module (guix monads)
> #:use-module (guix records)
> + #:use-module (guix scripts pack)
We cannot refer to (guix scripts …) modules from here (conceptually
(guix scripts …) modules are layered above the rest).
If needed, we can move the relevant bits to a new (guix pack) module and
use it here. (I didn’t spot which part of (guix scripts pack) is used.)
Ludo’.
From ef951ff51bf0e2b2b50c57fbf652b0677c1e6701 Mon Sep 17 00:00:00 2001
From: Alex Griffin <a@ajgrf.com>
Date: Sun, 6 Feb 2022 16:29:47 -0600
Subject: [PATCH 2/5] system: image: Add tarball support.
* 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.
---
gnu/system/image.scm | 82 +++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 81 insertions(+), 1 deletion(-)
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,6 +25,7 @@ (define-module (gnu system image)
#:use-module (guix modules)
#:use-module (guix monads)
#:use-module (guix records)
+ #:use-module (guix scripts pack)
#:use-module (guix store)
#:use-module (guix ui)
#:use-module (guix utils)
@@ -70,6 +72,7 @@ (define-module (gnu system image)
efi-disk-image
iso9660-image
docker-image
+ tarball-image
raw-with-offset-disk-image
image-with-os
@@ -78,6 +81,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
@@ -135,6 +139,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)
@@ -192,6 +200,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)
@@ -631,6 +644,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* ((shared-network? (image-shared-network? image))
+ (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.
@@ -640,7 +718,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)))))
@@ -778,6 +856,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*
--
2.34.0