@@ -56,7 +56,7 @@
Copyright @copyright{} 2017, 2018, 2019, 2020 Arun Isaac@*
Copyright @copyright{} 2017 nee@*
Copyright @copyright{} 2018 Rutger Helling@*
-Copyright @copyright{} 2018, 2021 Oleg Pykhalov@*
+Copyright @copyright{} 2018, 2021, 2023 Oleg Pykhalov@*
Copyright @copyright{} 2018 Mike Gerwitz@*
Copyright @copyright{} 2018 Pierre-Antoine Rouby@*
Copyright @copyright{} 2018, 2019 Gábor Boskovits@*
@@ -6984,9 +6984,15 @@ Invoking guix pack
guix pack -f docker -S /bin=bin guile guile-readline
@end example
+or
+
+@example
+guix pack -f docker-layered -S /bin=bin guile guile-readline
+@end example
+
@noindent
-The result is a tarball that can be passed to the @command{docker load}
-command, followed by @code{docker run}:
+The result is a tarball with image or layered image that can be passed
+to the @command{docker load} command, followed by @code{docker run}:
@example
docker load < @var{file}
@@ -44347,6 +44353,8 @@ image Reference
@item @code{docker}, a Docker image.
+@item @code{docker-layered}, a layered Docker image.
+
@item @code{iso9660}, an ISO-9660 image.
@item @code{tarball}, a tar.gz image archive.
@@ -44682,6 +44690,10 @@ image-type Reference
Build an image based on the @code{docker-image} image.
@end defvar
+@defvar docker-layered-image-type
+Build a layered image based on the @code{docker-layered-image} image.
+@end defvar
+
@defvar raw-with-offset-image-type
Build an MBR image with a single partition starting at a @code{1024KiB}
offset. This is useful to leave some room to install a bootloader in
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -152,7 +153,7 @@ (define-syntax-rule (define-set-sanitizer name field set)
;; The supported image formats.
(define-set-sanitizer validate-image-format format
- (disk-image compressed-qcow2 docker iso9660 tarball wsl2))
+ (disk-image compressed-qcow2 docker docker-layered iso9660 tarball wsl2))
;; The supported partition table types.
(define-set-sanitizer validate-partition-table-type partition-table-type
@@ -4,6 +4,7 @@
;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -78,6 +79,7 @@ (define-module (gnu system image)
efi-disk-image
iso9660-image
docker-image
+ docker-layered-image
tarball-image
wsl2-image
raw-with-offset-disk-image
@@ -89,6 +91,7 @@ (define-module (gnu system image)
iso-image-type
uncompressed-iso-image-type
docker-image-type
+ docker-layered-image-type
tarball-image-type
wsl2-image-type
raw-with-offset-image-type
@@ -167,6 +170,10 @@ (define docker-image
(image-without-os
(format 'docker)))
+(define docker-layered-image
+ (image-without-os
+ (format 'docker-layered)))
+
(define tarball-image
(image-without-os
(format 'tarball)))
@@ -237,6 +244,11 @@ (define docker-image-type
(name 'docker)
(constructor (cut image-with-os docker-image <>))))
+(define docker-layered-image-type
+ (image-type
+ (name 'docker-layered)
+ (constructor (cut image-with-os docker-layered-image <>))))
+
(define tarball-image-type
(image-type
(name 'tarball)
@@ -633,9 +645,12 @@ (define (image-with-label base-image label)
(define* (system-docker-image image
#:key
- (name "docker-image"))
+ (name "docker-image")
+ (archiver tar)
+ layered-image?)
"Build a docker image for IMAGE. NAME is the base name to use for the
-output file."
+output file. If LAYERED-IMAGE? is true, the image will with many of the store
+paths being on their own layer to improve sharing between images."
(define boot-program
;; Program that runs the boot script of OS, which in turn starts shepherd.
(program-file "boot-program"
@@ -678,9 +693,11 @@ (define* (system-docker-image image
(use-modules (guix docker)
(guix build utils)
(gnu build image)
+ (srfi srfi-1)
(srfi srfi-19)
(guix build store-copy)
- (guix store database))
+ (guix store database)
+ (ice-9 receive))
;; Set the SQL schema location.
(sql-schema #$schema)
@@ -700,18 +717,31 @@ (define* (system-docker-image image
#:register-closures? #$register-closures?
#:deduplicate? #f
#:system-directory #$os)
- (build-docker-image
- #$output
- (cons* image-root
- (map store-info-item
- (call-with-input-file #$graph
- read-reference-graph)))
- #$os
- #:entry-point '(#$boot-program #$os)
- #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
- #:creation-time (make-time time-utc 0 1)
- #:system #$image-target
- #:transformations `((,image-root -> ""))))))))
+ (when #$layered-image?
+ (setenv "PATH"
+ (string-join (list #+(file-append archiver "/bin")
+ #+(file-append coreutils "/bin")
+ #+(file-append gzip "/bin"))
+ ":")))
+ (apply build-docker-image
+ (append (list #$output
+ (append (if #$layered-image?
+ '()
+ (list image-root))
+ (map store-info-item
+ (call-with-input-file #$graph
+ read-reference-graph)))
+ #$os
+ #:entry-point '(#$boot-program #$os)
+ #:compressor
+ '(#+(file-append gzip "/bin/gzip") "-9n")
+ #:creation-time (make-time time-utc 0 1)
+ #:system #$image-target
+ #:transformations `((,image-root -> "")))
+ (if #$layered-image?
+ (list #:root-system image-root
+ #:layered-image? #$layered-image?)
+ '()))))))))
(computed-file name builder
;; Allow offloading so that this I/O-intensive process
@@ -720,6 +750,18 @@ (define* (system-docker-image image
#:options `(#:references-graphs ((,graph ,os))
#:substitutable? ,substitutable?))))
+(define* (system-docker-layered-image image
+ #:key
+ (name "docker-image")
+ (archiver tar)
+ (layered-image? #t))
+ "Build a docker image for IMAGE. NAME is the base name to use for the
+output file."
+ (system-docker-image image
+ #:name name
+ #:archiver archiver
+ #:layered-image? layered-image?))
+
;;;
;;; Tarball image.
@@ -811,7 +853,7 @@ (define (image->root-file-system image)
"Return the IMAGE root partition file-system type."
(case (image-format image)
((iso9660) "iso9660")
- ((docker tarball wsl2) "dummy")
+ ((docker docker-layered tarball wsl2) "dummy")
(else
(partition-file-system (find-root-partition image)))))
@@ -948,6 +990,8 @@ (define* (system-image image)
("bootcfg" ,bootcfg))))
((memq image-format '(docker))
(system-docker-image image*))
+ ((memq image-format '(docker-layered))
+ (system-docker-layered-image image*))
((memq image-format '(tarball))
(system-tarball-image image*))
((memq image-format '(wsl2))
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2019-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -43,7 +44,8 @@ (define-module (gnu tests docker)
#:use-module (guix build-system trivial)
#:use-module ((guix licenses) #:prefix license:)
#:export (%test-docker
- %test-docker-system))
+ %test-docker-system
+ %test-docker-layered-system))
(define %docker-os
(simple-operating-system
@@ -316,3 +318,19 @@ (define %test-docker-system
(locale-libcs (list glibc)))
#:type docker-image-type)))
run-docker-system-test)))))
+
+(define %test-docker-layered-system
+ (system-test
+ (name "docker-layered-system")
+ (description "Run a system image as produced by @command{guix system
+docker-layered-image} inside Docker.")
+ (value (with-monad %store-monad
+ (>>= (lower-object
+ (system-image (os->image
+ (operating-system
+ (inherit (simple-operating-system))
+ ;; Use locales for a single libc to
+ ;; reduce space requirements.
+ (locale-libcs (list glibc)))
+ #:type docker-layered-image-type)))
+ run-docker-system-test)))))
@@ -3,6 +3,7 @@
;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,6 +29,8 @@ (define-module (guix docker)
delete-file-recursively
with-directory-excursion
invoke))
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:use-module (gnu build install)
#:use-module (json) ;guile-json
#:use-module (srfi srfi-1)
@@ -38,6 +41,9 @@ (define-module (guix docker)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 receive)
#:export (build-docker-image))
;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
@@ -92,12 +98,12 @@ (define (canonicalize-repository-name name)
(make-string (- min-length l) padding-character)))
(_ normalized-name))))
-(define* (manifest path id #:optional (tag "guix"))
+(define* (manifest path layers #:optional (tag "guix"))
"Generate a simple image manifest."
(let ((tag (canonicalize-repository-name tag)))
`#(((Config . "config.json")
(RepoTags . #(,(string-append tag ":latest")))
- (Layers . #(,(string-append id "/layer.tar")))))))
+ (Layers . ,(list->vector layers))))))
;; According to the specifications this is required for backwards
;; compatibility. It duplicates information provided by the manifest.
@@ -106,8 +112,8 @@ (define* (repositories path id #:optional (tag "guix"))
`((,(canonicalize-repository-name tag) . ((latest . ,id)))))
;; See https://github.com/opencontainers/image-spec/blob/master/config.md
-(define* (config layer time arch #:key entry-point (environment '()))
- "Generate a minimal image configuration for the given LAYER file."
+(define* (config layers-diff-ids time arch #:key entry-point (environment '()))
+ "Generate a minimal image configuration for the given LAYERS files."
;; "architecture" must be values matching "platform.arch" in the
;; runtime-spec at
;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
@@ -125,7 +131,7 @@ (define* (config layer time arch #:key entry-point (environment '()))
(container_config . #nil)
(os . "linux")
(rootfs . ((type . "layers")
- (diff_ids . #(,(layer-diff-id layer)))))))
+ (diff_ids . ,(list->vector layers-diff-ids))))))
(define directive-file
;; Return the file or directory created by a 'evaluate-populate-directive'
@@ -136,6 +142,37 @@ (define directive-file
(('directory name _ ...)
(string-trim name #\/))))
+(define %docker-image-max-layers
+ 100)
+
+(define (paths-split-sort paths)
+ "Split list of PATHS at %DOCKER-IMAGE-MAX-LAYERS and sort by disk usage."
+ (let* ((paths-length (length paths))
+ (port (apply open-pipe* OPEN_READ
+ (append '("du" "--summarize") paths)))
+ (output (read-string port)))
+ (close-port port)
+ (receive (head tail)
+ (split-at
+ (map (match-lambda ((size . path) path))
+ (sort (map (lambda (line)
+ (match (string-split line #\tab)
+ ((size path)
+ (cons (string->number size) path))))
+ (string-split
+ (string-trim-right output #\newline)
+ #\newline))
+ (lambda (path1 path2)
+ (< (match path2 ((size . _) size))
+ (match path1 ((size . _) size))))))
+ (if (>= paths-length %docker-image-max-layers)
+ (- %docker-image-max-layers 2)
+ (1- paths-length)))
+ (list head tail))))
+
+(define (create-empty-tar file)
+ (invoke "tar" "-cf" file "--files-from" "/dev/null"))
+
(define* (build-docker-image image paths prefix
#:key
(repository "guix")
@@ -146,11 +183,13 @@ (define* (build-docker-image image paths prefix
entry-point
(environment '())
compressor
- (creation-time (current-time time-utc)))
- "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX
-must be a store path that is a prefix of any store paths in PATHS. REPOSITORY
-is a descriptive name that will show up in \"REPOSITORY\" column of the output
-of \"docker images\".
+ (creation-time (current-time time-utc))
+ layered-image?
+ root-system)
+ "Write to IMAGE a layerer Docker image archive containing the given PATHS.
+PREFIX must be a store path that is a prefix of any store paths in PATHS.
+REPOSITORY is a descriptive name that will show up in \"REPOSITORY\" column of
+the output of \"docker images\".
When DATABASE is true, copy it to /var/guix/db in the image and create
/var/guix/gcroots and friends.
@@ -172,7 +211,14 @@ (define* (build-docker-image image paths prefix
SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
PATHS are for; it is used to produce metadata in the image. Use COMPRESSOR, a
command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use CREATION-TIME, a
-SRFI-19 time-utc object, as the creation time in metadata."
+SRFI-19 time-utc object, as the creation time in metadata.
+
+When LAYERED-IMAGE? is true build layered image, providing a Docker
+image with many of the store paths being on their own layer to improve sharing
+between images.
+
+ROOT-SYSTEM is a directory with a provisioned root file system, which will be
+added to image as a layer."
(define (sanitize path-fragment)
(escape-special-chars
;; GNU tar strips the leading slash off of absolute paths before applying
@@ -203,6 +249,53 @@ (define* (build-docker-image image paths prefix
(if (eq? '() transformations)
'()
`("--transform" ,(transformations->expression transformations))))
+ (define layers-hashes
+ (match-lambda
+ (((head ...) (tail ...) id)
+ (create-empty-tar "image.tar")
+ (let* ((head-layers
+ (map
+ (lambda (file)
+ (invoke "tar" "cf" "layer.tar" file)
+ (let* ((file-hash (layer-diff-id "layer.tar"))
+ (file-name (string-append file-hash "/layer.tar")))
+ (mkdir file-hash)
+ (rename-file "layer.tar" file-name)
+ (invoke "tar" "-rf" "image.tar" file-name)
+ (delete-file file-name)
+ file-hash))
+ head))
+ (tail-layer
+ (begin
+ (create-empty-tar "layer.tar")
+ (for-each (lambda (file)
+ (invoke "tar" "-rf" "layer.tar" file))
+ tail)
+ (let* ((file-hash (layer-diff-id "layer.tar"))
+ (file-name (string-append file-hash "/layer.tar")))
+ (mkdir file-hash)
+ (rename-file "layer.tar" file-name)
+ (invoke "tar" "-rf" "image.tar" file-name)
+ (delete-file file-name)
+ file-hash)))
+ (customization-layer
+ (let* ((file-id (string-append id "/layer.tar"))
+ (file-hash (layer-diff-id file-id))
+ (file-name (string-append file-hash "/layer.tar")))
+ (mkdir file-hash)
+ (rename-file file-id file-name)
+ (invoke "tar" "-rf" "image.tar" file-name)
+ file-hash))
+ (all-layers
+ (append head-layers (list tail-layer customization-layer))))
+ (with-output-to-file "manifest.json"
+ (lambda ()
+ (scm->json (manifest prefix
+ (map (cut string-append <> "/layer.tar")
+ all-layers)
+ repository))))
+ (invoke "tar" "-rf" "image.tar" "manifest.json")
+ all-layers))))
(let* ((directory "/tmp/docker-image") ;temporary working directory
(id (docker-id prefix))
(time (date->string (time-utc->date creation-time) "~4"))
@@ -229,26 +322,39 @@ (define* (build-docker-image image paths prefix
(with-output-to-file "json"
(lambda () (scm->json (image-description id time))))
- ;; Create a directory for the non-store files that need to go into the
- ;; archive.
- (mkdir "extra")
+ (if root-system
+ (let ((directory (getcwd)))
+ (with-directory-excursion root-system
+ (apply invoke "tar"
+ "-cf" (string-append directory "/layer.tar")
+ `(,@transformation-options
+ ,@(tar-base-options)
+ ,@(scandir "."
+ (lambda (file)
+ (not (member file '("." "..")))))))))
+ (begin
+ ;; Create a directory for the non-store files that need to go
+ ;; into the archive.
+ (mkdir "extra")
- (with-directory-excursion "extra"
- ;; Create non-store files.
- (for-each (cut evaluate-populate-directive <> "./")
- extra-files)
+ (with-directory-excursion "extra"
+ ;; Create non-store files.
+ (for-each (cut evaluate-populate-directive <> "./")
+ extra-files)
- (when database
- ;; Initialize /var/guix, assuming PREFIX points to a profile.
- (install-database-and-gc-roots "." database prefix))
+ (when database
+ ;; Initialize /var/guix, assuming PREFIX points to a
+ ;; profile.
+ (install-database-and-gc-roots "." database prefix))
- (apply invoke "tar" "-cf" "../layer.tar"
- `(,@transformation-options
- ,@(tar-base-options)
- ,@paths
- ,@(scandir "."
- (lambda (file)
- (not (member file '("." ".."))))))))
+ (apply invoke "tar" "-cf" "../layer.tar"
+ `(,@transformation-options
+ ,@(tar-base-options)
+ ,@(if layered-image? '() paths)
+ ,@(scandir "."
+ (lambda (file)
+ (not (member file '("." ".."))))))))
+ (delete-file-recursively "extra")))
;; It is possible for "/" to show up in the archive, especially when
;; applying transformations. For example, the transformation
@@ -261,24 +367,36 @@ (define* (build-docker-image image paths prefix
;; error messages.
(with-error-to-port (%make-void-port "w")
(lambda ()
- (system* "tar" "--delete" "/" "-f" "layer.tar")))
-
- (delete-file-recursively "extra"))
+ (system* "tar" "--delete" "/" "-f" "layer.tar"))))
(with-output-to-file "config.json"
(lambda ()
- (scm->json (config (string-append id "/layer.tar")
- time arch
- #:environment environment
- #:entry-point entry-point))))
- (with-output-to-file "manifest.json"
- (lambda ()
- (scm->json (manifest prefix id repository))))
- (with-output-to-file "repositories"
- (lambda ()
- (scm->json (repositories prefix id repository)))))
-
- (apply invoke "tar" "-cf" image "-C" directory
- `(,@(tar-base-options #:compressor compressor)
- "."))
+ (scm->json
+ (config (if layered-image?
+ (layers-hashes (append (paths-split-sort paths)
+ (list id)))
+ (list (layer-diff-id (string-append id "/layer.tar"))))
+ time arch
+ #:environment environment
+ #:entry-point entry-point))))
+ (if layered-image?
+ (begin
+ (invoke "tar" "-rf" "image.tar" "config.json")
+ (if compressor
+ (begin
+ (apply invoke `(,@compressor "image.tar"))
+ (copy-file "image.tar.gz" image))
+ (copy-file "image.tar" image)))
+ (begin
+ (with-output-to-file "manifest.json"
+ (lambda ()
+ (scm->json (manifest prefix
+ (list (string-append id "/layer.tar"))
+ repository))))
+ (with-output-to-file "repositories"
+ (lambda ()
+ (scm->json (repositories prefix id repository))))
+ (apply invoke "tar" "-cf" image
+ `(,@(tar-base-options #:compressor compressor)
+ ".")))))
(delete-file-recursively directory)))
@@ -8,6 +8,7 @@
;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,6 +29,7 @@ (define-module (guix scripts pack)
#:use-module (guix scripts)
#:use-module (guix ui)
#:use-module (guix gexp)
+ #:use-module ((guix build utils) #:select (%xz-parallel-args))
#:use-module (guix utils)
#:use-module (guix store)
#:use-module ((guix status) #:select (with-status-verbosity))
@@ -53,6 +55,8 @@ (define-module (guix scripts pack)
#:use-module ((gnu packages compression) #:hide (zip))
#:use-module (gnu packages guile)
#:use-module (gnu packages base)
+ #:use-module (gnu packages shells)
+ #:autoload (gnu packages package-management) (guix)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:autoload (gnu packages guile) (guile2.0-json guile-json)
#:use-module (srfi srfi-1)
@@ -67,6 +71,7 @@ (define-module (guix scripts pack)
debian-archive
rpm-archive
docker-image
+ docker-layered-image
squashfs-image
%formats
@@ -597,12 +602,14 @@ (define* (docker-image name profile
localstatedir?
(symlinks '())
(archiver tar)
- (extra-options '()))
+ (extra-options '())
+ layered-image?)
"Return a derivation to construct a Docker image of PROFILE. The
image is a tarball conforming to the Docker Image Specification, compressed
with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it
must a be a GNU triplet and it is used to derive the architecture metadata in
-the image."
+the image. If LAYERED-IMAGE? is true, the image will with many of the
+store paths being on their own layer to improve sharing between images."
(define database
(and localstatedir?
(file-append (store-database (list profile))
@@ -653,7 +660,13 @@ (define* (docker-image name profile
`((directory "/tmp" ,(getuid) ,(getgid) #o1777)
,@(append-map symlink->directives '#$symlinks)))
- (setenv "PATH" #+(file-append archiver "/bin"))
+ (setenv "PATH"
+ (string-join `(#+(file-append archiver "/bin")
+ #+@(if layered-image?
+ (list (file-append coreutils "/bin")
+ (file-append gzip "/bin"))
+ '()))
+ ":"))
(build-docker-image #$output
(map store-info-item
@@ -671,7 +684,8 @@ (define* (docker-image name profile
#$entry-point)))
#:extra-files directives
#:compressor #+(compressor-command compressor)
- #:creation-time (make-time time-utc 0 1))))))
+ #:creation-time (make-time time-utc 0 1)
+ #:layered-image? #$layered-image?)))))
(gexp->derivation (string-append name ".tar"
(compressor-extension compressor))
@@ -679,6 +693,33 @@ (define* (docker-image name profile
#:target target
#:references-graphs `(("profile" ,profile))))
+(define* (docker-layered-image name profile
+ #:key target
+ (profile-name "guix-profile")
+ (compressor (first %compressors))
+ entry-point
+ localstatedir?
+ (symlinks '())
+ (archiver tar)
+ (extra-options '())
+ (layered-image? #t))
+ "Return a derivation to construct a Docker image of PROFILE. The image is a
+tarball conforming to the Docker Image Specification, compressed with
+COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it must a
+be a GNU triplet and it is used to derive the architecture metadata in the
+image. If LAYERED-IMAGE? is true, the image will with many of the store paths
+being on their own layer to improve sharing between images."
+ (docker-image name profile
+ #:target target
+ #:profile-name profile-name
+ #:compressor compressor
+ #:entry-point entry-point
+ #:localstatedir? localstatedir?
+ #:symlinks symlinks
+ #:archiver archiver
+ #:extra-options extra-options
+ #:layered-image? layered-image?))
+
;;;
;;; Debian archive format.
@@ -1353,6 +1394,7 @@ (define %formats
`((tarball . ,self-contained-tarball)
(squashfs . ,squashfs-image)
(docker . ,docker-image)
+ (docker-layered . ,docker-layered-image)
(deb . ,debian-archive)
(rpm . ,rpm-archive)))
@@ -1361,15 +1403,17 @@ (define (show-formats)
(display (G_ "The supported formats for 'guix pack' are:"))
(newline)
(display (G_ "
- tarball Self-contained tarball, ready to run on another machine"))
+ tarball Self-contained tarball, ready to run on another machine"))
+ (display (G_ "
+ squashfs Squashfs image suitable for Singularity"))
(display (G_ "
- squashfs Squashfs image suitable for Singularity"))
+ docker Tarball ready for 'docker load'"))
(display (G_ "
- docker Tarball ready for 'docker load'"))
+ docker-layered Tarball with a layered image ready for 'docker load'"))
(display (G_ "
- deb Debian archive installable via dpkg/apt"))
+ deb Debian archive installable via dpkg/apt"))
(display (G_ "
- rpm RPM archive installable via rpm/yum"))
+ rpm RPM archive installable via rpm/yum"))
(newline))
(define (required-option symbol)
@@ -11,6 +11,7 @@
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -727,13 +728,15 @@ (define* (system-derivation-for-action image action
#:graphic? graphic?
#:disk-image-size image-size
#:mappings mappings))
- ((image disk-image vm-image docker-image)
+ ((image disk-image vm-image docker-image docker-layered-image)
(when (eq? action 'disk-image)
(warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
(when (eq? action 'vm-image)
(warning (G_ "'vm-image' is deprecated: use 'image' instead~%")))
(when (eq? action 'docker-image)
(warning (G_ "'docker-image' is deprecated: use 'image' instead~%")))
+ (when (eq? action 'docker-layered-image)
+ (warning (G_ "'docker-layered-image' is deprecated: use 'image' instead~%")))
(lower-object (system-image image))))))
(define (maybe-suggest-running-guix-pull)
@@ -980,6 +983,8 @@ (define (show-help)
image build a Guix System image\n"))
(display (G_ "\
docker-image build a Docker image\n"))
+ (display (G_ "\
+ docker-layered-image build a Docker layered image\n"))
(display (G_ "\
init initialize a root file system to run GNU\n"))
(display (G_ "\
@@ -1193,7 +1198,7 @@ (define actions '("build" "container" "vm" "vm-image" "image" "disk-image"
"list-generations" "describe"
"delete-generations" "roll-back"
"switch-generation" "search" "edit"
- "docker-image"))
+ "docker-image" "docker-layered-image"))
(define (process-action action args opts)
"Process ACTION, a sub-command, with the arguments are listed in ARGS.
@@ -1242,6 +1247,8 @@ (define (process-action action args opts)
(image (let* ((image-type (case action
((vm-image) qcow2-image-type)
((docker-image) docker-image-type)
+ ((docker-layered-image)
+ docker-layered-image-type)
(else image-type)))
(image-size (assoc-ref opts 'image-size))
(volatile?
@@ -2,6 +2,7 @@
;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,6 +30,7 @@ (define-module (test-pack)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (guix utils)
+ #:use-module ((guix build utils) #:select (%store-directory))
#:use-module (gnu packages)
#:use-module ((gnu packages base) #:select (glibc-utf8-locales))
#:use-module (gnu packages bootstrap)
@@ -250,6 +252,52 @@ (define rpm-for-tests
(mkdir #$output)))))))
(built-derivations (list check))))
+ (unless store (test-skip 1))
+ (test-assertm "docker-layered-image + localstatedir" store
+ (mlet* %store-monad
+ ((guile (set-guile-for-build (default-guile)))
+ (profile -> (profile
+ (content (packages->manifest (list %bootstrap-guile)))
+ (hooks '())
+ (locales? #f)))
+ (tarball (docker-layered-image "docker-pack" profile
+ #:symlinks '(("/bin/Guile" -> "bin/guile"))
+ #:localstatedir? #t))
+ (check (gexp->derivation "check-tarball"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 match))
+
+ (define bin
+ (string-append "." #$profile "/bin"))
+
+ (define store
+ (string-append "." #$(%store-directory)))
+
+ (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
+ (mkdir "base")
+ (with-directory-excursion "base"
+ (invoke "tar" "xvf" #$tarball))
+
+ (match (find-files "base" "layer.tar")
+ ((layers ...)
+ (for-each (lambda (layer)
+ (invoke "tar" "xvf" layer)
+ (invoke "chmod" "--recursive" "u+w" store))
+ layers)))
+
+ (when
+ (and (file-exists? (string-append bin "/guile"))
+ (file-exists? "var/guix/db/db.sqlite")
+ (file-is-directory? "tmp")
+ (string=? (string-append #$%bootstrap-guile "/bin")
+ (pk 'binlink (readlink bin)))
+ (string=? (string-append #$profile "/bin/guile")
+ (pk 'guilelink (readlink "bin/Guile"))))
+ (mkdir #$output)))))))
+ (built-derivations (list check))))
+
(unless store (test-skip 1))
(test-assertm "squashfs-image + localstatedir" store
(mlet* %store-monad