[bug#62153] [PATCH] guix: docker: Build layered image.

[Oleg Pykhalov <go.wigust@gmail.com>]

* doc/guix.texi (Invoking guix pack): Document docker-layered format.
(image Reference): Same.
(image-type Reference): Document docker-layered-image-type.
* gnu/image.scm
(validate-image-format)[docker-layered]: New image format.
* gnu/system/image.scm
(docker-layered-image, docker-layered-image-type): New variables.
(system-docker-image)[layered-image?]: New argument.
(system-docker-layered-image): New procedure.
(image->root-file-system)[docker-layered]: New image format.
* gnu/tests/docker.scm (%test-docker-layered-system): New test.
* guix/docker.scm (%docker-image-max-layers): New variable.
(build-docker-image)[stream-layered-image, root-system]: New arguments.
* guix/scripts/pack.scm (stream-layered-image.py): New variable.
(docker-image)[layered-image?]: New argument.
(docker-layered-image): New procedure.
(%formats)[docker-layered]: New format.
(show-formats): Document this.
* guix/scripts/system.scm
(system-derivation-for-action)[docker-layered-image]: New action.
(show-help): Document this.
(actions)[docker-layered-image]: New action.
(process-action): Add this.
* tests/pack.scm: Add "docker-layered-image + localstatedir" test.
---
 doc/guix.texi           |  18 +++-
 gnu/image.scm           |   3 +-
 gnu/system/image.scm    |  76 +++++++++++----
 gnu/tests/docker.scm    |  20 +++-
 guix/docker.scm         | 205 +++++++++++++++++++++++++++++++---------
 guix/scripts/pack.scm   |  62 ++++++++++--
 guix/scripts/system.scm |  11 ++-
 tests/pack.scm          |  48 ++++++++++
 8 files changed, 366 insertions(+), 77 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 5fd2449ed5..1c95ec4320 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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}
@@ -44309,6 +44315,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.
@@ -44644,6 +44652,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
diff --git a/gnu/image.scm b/gnu/image.scm
index 523653dd77..8a6a0d8479 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -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
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index afef79185f..3a502f19ec 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -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?))
+
 \f
 ;;;
 ;;; 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))
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index edc9804414..0cccc02ad2 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -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)))))
diff --git a/guix/docker.scm b/guix/docker.scm
index 5e6460f43f..e10b940aa4 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -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,33 @@ (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")
+            (apply invoke `(,@compressor "image.tar"))
+            (copy-file "image.tar.gz" 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)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 0dc9979194..3fefd2eac3 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -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?))
+
 \f
 ;;;
 ;;; 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)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index d7163dd3eb..e4bf0347c7 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -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?
diff --git a/tests/pack.scm b/tests/pack.scm
index ce5a2f8a53..432ab1b2ea 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -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
-- 
2.38.0