guix-patches
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

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


From: Oleg Pykhalov
Subject: [bug#62153] [PATCH 1/2] guix: docker: Build layered image.
Date: Tue, 14 Mar 2023 03:24:52 +0300

* gnu/packages/aux-files/python/stream-layered-image.py: New file.
* Makefile.am (AUX_FILES): Add this.
* 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.
* tests/pack.scm: Add docker-layered-image + localstatedir test.
* 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.
* gnu/system/image.scm (docker-layered-image, docker-layered-image-type): New
variables.
(system-docker-image)[layered-image?]: New argument.
(stream-layered-image.py): New variable.
(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.
* gnu/image.scm (validate-image-format)[docker-layered]: New image format.
* doc/guix.texi (Invoking guix pack): Document docker-layered format.
(image Reference): Same.
(image-type Reference): Document docker-layered-image-type.
---
 Makefile.am                                   |   3 +-
 doc/guix.texi                                 |  18 +-
 gnu/image.scm                                 |   3 +-
 .../aux-files/python/stream-layered-image.py  | 391 ++++++++++++++++++
 gnu/system/image.scm                          |  84 +++-
 gnu/tests/docker.scm                          |  20 +-
 guix/docker.scm                               | 182 ++++++--
 guix/scripts/pack.scm                         | 105 +++--
 guix/scripts/system.scm                       |  11 +-
 tests/pack.scm                                |  48 +++
 10 files changed, 779 insertions(+), 86 deletions(-)
 create mode 100644 gnu/packages/aux-files/python/stream-layered-image.py

diff --git a/Makefile.am b/Makefile.am
index 23b939b674..9aca84f8f8 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -11,7 +11,7 @@
 # Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
 # Copyright © 2018 Nikita <nikita@n0.is>
 # Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
-# Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
+# Copyright © 2018, 2023 Oleg Pykhalov <go.wigust@gmail.com>
 # Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
 # Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
 # Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
@@ -435,6 +435,7 @@ AUX_FILES =                                         \
   gnu/packages/aux-files/python/sanity-check.py                \
   gnu/packages/aux-files/python/sanity-check-next.py   \
   gnu/packages/aux-files/python/sitecustomize.py       \
+  gnu/packages/aux-files/python/stream-layered-image.py        \
   gnu/packages/aux-files/renpy/renpy.in        \
   gnu/packages/aux-files/run-in-namespace.c
 
diff --git a/doc/guix.texi b/doc/guix.texi
index 39932d5aad..fa4b7586c9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -56,7 +56,7 @@ Copyright @copyright{} 2017 Andy Wingo@*
 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@*
@@ -6837,9 +6837,15 @@ the following command:
 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}
@@ -43274,6 +43280,8 @@ one or multiple partitions.
 
 @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.
@@ -43605,6 +43613,10 @@ Build an image based on the @code{iso9660-image} image 
but with the
 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-with-syntax-properties (name (value properties))
 
 ;; 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/packages/aux-files/python/stream-layered-image.py 
b/gnu/packages/aux-files/python/stream-layered-image.py
new file mode 100644
index 0000000000..9ad2168c2d
--- /dev/null
+++ b/gnu/packages/aux-files/python/stream-layered-image.py
@@ -0,0 +1,391 @@
+"""
+This script generates a Docker image from a set of store paths. Uses
+Docker Image Specification v1.2 as reference [1].
+
+It expects a JSON file with the following properties and writes the
+image as an uncompressed tarball to stdout:
+
+* "architecture", "config", "os", "created", "repo_tag" correspond to
+  the fields with the same name on the image spec [2].
+* "created" can be "now".
+* "created" is also used as mtime for files added to the image.
+* "store_layers" is a list of layers in ascending order, where each
+  layer is the list of store paths to include in that layer.
+
+The main challenge for this script to create the final image in a
+streaming fashion, without dumping any intermediate data to disk
+for performance.
+
+A docker image has each layer contents archived as separate tarballs,
+and they later all get enveloped into a single big tarball in a
+content addressed fashion. However, because how "tar" format works,
+we have to know about the name (which includes the checksum in our
+case) and the size of the tarball before we can start adding it to the
+outer tarball.  We achieve that by creating the layer tarballs twice;
+on the first iteration we calculate the file size and the checksum,
+and on the second one we actually stream the contents. 'add_layer_dir'
+function does all this.
+
+[1]: https://github.com/moby/moby/blob/master/image/spec/v1.2.md
+[2]: 
https://github.com/moby/moby/blob/4fb59c20a4fb54f944fe170d0ff1d00eb4a24d6f/image/spec/v1.2.md#image-json-field-descriptions
+"""  # noqa: E501
+
+
+import io
+import os
+import re
+import sys
+import json
+import hashlib
+import pathlib
+import tarfile
+import itertools
+import threading
+from datetime import datetime, timezone
+from collections import namedtuple
+
+
+def archive_paths_to(obj, paths, mtime):
+    """
+    Writes the given store paths as a tar file to the given stream.
+
+    obj: Stream to write to. Should have a 'write' method.
+    paths: List of store paths.
+    """
+
+    # gettarinfo makes the paths relative, this makes them
+    # absolute again
+    def append_root(ti):
+        ti.name = "/" + ti.name
+        return ti
+
+    def apply_filters(ti):
+        ti.mtime = mtime
+        ti.uid = 0
+        ti.gid = 0
+        ti.uname = "root"
+        ti.gname = "root"
+        return ti
+
+    def nix_root(ti):
+        ti.mode = 0o0555  # r-xr-xr-x
+        return ti
+
+    def dir(path):
+        ti = tarfile.TarInfo(path)
+        ti.type = tarfile.DIRTYPE
+        return ti
+
+    with tarfile.open(fileobj=obj, mode="w|") as tar:
+        # To be consistent with the docker utilities, we need to have
+        # these directories first when building layer tarballs.
+        tar.addfile(apply_filters(nix_root(dir("/gnu"))))
+        tar.addfile(apply_filters(nix_root(dir("/gnu/store"))))
+
+        for path in paths:
+            path = pathlib.Path(path)
+            if path.is_symlink():
+                files = [path]
+            else:
+                files = itertools.chain([path], path.rglob("*"))
+
+            for filename in sorted(files):
+                ti = append_root(tar.gettarinfo(filename))
+
+                # copy hardlinks as regular files
+                if ti.islnk():
+                    ti.type = tarfile.REGTYPE
+                    ti.linkname = ""
+                    ti.size = filename.stat().st_size
+
+                ti = apply_filters(ti)
+                if ti.isfile():
+                    with open(filename, "rb") as f:
+                        tar.addfile(ti, f)
+                else:
+                    tar.addfile(ti)
+
+
+class ExtractChecksum:
+    """
+    A writable stream which only calculates the final file size and
+    sha256sum, while discarding the actual contents.
+    """
+
+    def __init__(self):
+        self._digest = hashlib.sha256()
+        self._size = 0
+
+    def write(self, data):
+        self._digest.update(data)
+        self._size += len(data)
+
+    def extract(self):
+        """
+        Returns: Hex-encoded sha256sum and size as a tuple.
+        """
+        return (self._digest.hexdigest(), self._size)
+
+
+FromImage = namedtuple("FromImage", ["tar", "manifest_json", "image_json"])
+# Some metadata for a layer
+LayerInfo = namedtuple("LayerInfo", ["size", "checksum", "path", "paths"])
+
+
+def load_from_image(from_image_str):
+    """
+    Loads the given base image, if any.
+
+    from_image_str: Path to the base image archive.
+
+    Returns: A 'FromImage' object with references to the loaded base image,
+             or 'None' if no base image was provided.
+    """
+    if from_image_str is None:
+        return None
+
+    base_tar = tarfile.open(from_image_str)
+
+    manifest_json_tarinfo = base_tar.getmember("manifest.json")
+    with base_tar.extractfile(manifest_json_tarinfo) as f:
+        manifest_json = json.load(f)
+
+    image_json_tarinfo = base_tar.getmember(manifest_json[0]["Config"])
+    with base_tar.extractfile(image_json_tarinfo) as f:
+        image_json = json.load(f)
+
+    return FromImage(base_tar, manifest_json, image_json)
+
+
+def add_base_layers(tar, from_image):
+    """
+    Adds the layers from the given base image to the final image.
+
+    tar: 'tarfile.TarFile' object for new layers to be added to.
+    from_image: 'FromImage' object with references to the loaded base image.
+    """
+    if from_image is None:
+        print("No 'fromImage' provided", file=sys.stderr)
+        return []
+
+    layers = from_image.manifest_json[0]["Layers"]
+    checksums = from_image.image_json["rootfs"]["diff_ids"]
+    layers_checksums = zip(layers, checksums)
+
+    for num, (layer, checksum) in enumerate(layers_checksums, start=1):
+        layer_tarinfo = from_image.tar.getmember(layer)
+        checksum = re.sub(r"^sha256:", "", checksum)
+
+        tar.addfile(layer_tarinfo, from_image.tar.extractfile(layer_tarinfo))
+        path = layer_tarinfo.path
+        size = layer_tarinfo.size
+
+        print("Adding base layer", num, "from", path, file=sys.stderr)
+        yield LayerInfo(size=size, checksum=checksum, path=path, paths=[path])
+
+    from_image.tar.close()
+
+
+def overlay_base_config(from_image, final_config):
+    """
+    Overlays the final image 'config' JSON on top of selected defaults from the
+    base image 'config' JSON.
+
+    from_image: 'FromImage' object with references to the loaded base image.
+    final_config: 'dict' object of the final image 'config' JSON.
+    """
+    if from_image is None:
+        return final_config
+
+    base_config = from_image.image_json["config"]
+
+    # Preserve environment from base image
+    final_env = base_config.get("Env", []) + final_config.get("Env", [])
+    if final_env:
+        # Resolve duplicates (last one wins) and format back as list
+        resolved_env = {entry.split("=", 1)[0]: entry for entry in final_env}
+        final_config["Env"] = list(resolved_env.values())
+    return final_config
+
+
+def add_layer_dir(tar, paths, store_dir, mtime):
+    """
+    Appends given store paths to a TarFile object as a new layer.
+
+    tar: 'tarfile.TarFile' object for the new layer to be added to.
+    paths: List of store paths.
+    store_dir: the root directory of the nix store
+    mtime: 'mtime' of the added files and the layer tarball.
+           Should be an integer representing a POSIX time.
+
+    Returns: A 'LayerInfo' object containing some metadata of
+             the layer added.
+    """
+
+    invalid_paths = [i for i in paths if not i.startswith(store_dir)]
+    assert len(invalid_paths) == 0, \
+        f"Expecting absolute paths from {store_dir}, but got: {invalid_paths}"
+
+    # First, calculate the tarball checksum and the size.
+    extract_checksum = ExtractChecksum()
+    archive_paths_to(
+        extract_checksum,
+        paths,
+        mtime=mtime,
+    )
+    (checksum, size) = extract_checksum.extract()
+
+    path = f"{checksum}/layer.tar"
+    layer_tarinfo = tarfile.TarInfo(path)
+    layer_tarinfo.size = size
+    layer_tarinfo.mtime = mtime
+
+    # Then actually stream the contents to the outer tarball.
+    read_fd, write_fd = os.pipe()
+    with open(read_fd, "rb") as read, open(write_fd, "wb") as write:
+        def producer():
+            archive_paths_to(
+                write,
+                paths,
+                mtime=mtime,
+            )
+            write.close()
+
+        # Closing the write end of the fifo also closes the read end,
+        # so we don't need to wait until this thread is finished.
+        #
+        # Any exception from the thread will get printed by the default
+        # exception handler, and the 'addfile' call will fail since it
+        # won't be able to read required amount of bytes.
+        threading.Thread(target=producer).start()
+        tar.addfile(layer_tarinfo, read)
+
+    return LayerInfo(size=size, checksum=checksum, path=path, paths=paths)
+
+
+def add_customisation_layer(target_tar, customisation_layer, mtime):
+    """
+    Adds the customisation layer as a new layer. This is layer is structured
+    differently; given store path has the 'layer.tar' and corresponding
+    sha256sum ready.
+
+    tar: 'tarfile.TarFile' object for the new layer to be added to.
+    customisation_layer: Path containing the layer archive.
+    mtime: 'mtime' of the added layer tarball.
+    """
+
+    checksum_path = os.path.join(customisation_layer, "checksum")
+    with open(checksum_path) as f:
+        checksum = f.read().strip()
+    assert len(checksum) == 64, f"Invalid sha256 at ${checksum_path}."
+
+    layer_path = os.path.join(customisation_layer, "layer.tar")
+
+    path = f"{checksum}/layer.tar"
+    tarinfo = target_tar.gettarinfo(layer_path)
+    tarinfo.name = path
+    tarinfo.mtime = mtime
+
+    with open(layer_path, "rb") as f:
+        target_tar.addfile(tarinfo, f)
+
+    return LayerInfo(
+      size=None,
+      checksum=checksum,
+      path=path,
+      paths=[customisation_layer]
+    )
+
+
+def add_bytes(tar, path, content, mtime):
+    """
+    Adds a file to the tarball with given path and contents.
+
+    tar: 'tarfile.TarFile' object.
+    path: Path of the file as a string.
+    content: Contents of the file.
+    mtime: 'mtime' of the file. Should be an integer representing a POSIX time.
+    """
+    assert type(content) is bytes
+
+    ti = tarfile.TarInfo(path)
+    ti.size = len(content)
+    ti.mtime = mtime
+    tar.addfile(ti, io.BytesIO(content))
+
+
+def main():
+    with open(sys.argv[1], "r") as f:
+        conf = json.load(f)
+
+    created = (
+      datetime.now(tz=timezone.utc)
+      if conf["created"] == "now"
+      else datetime.fromisoformat(conf["created"])
+    )
+    mtime = int(created.timestamp())
+    store_dir = conf["store_dir"]
+
+    from_image = load_from_image(conf["from_image"])
+
+    with tarfile.open(mode="w|", fileobj=sys.stdout.buffer) as tar:
+        layers = []
+        layers.extend(add_base_layers(tar, from_image))
+
+        start = len(layers) + 1
+        for num, store_layer in enumerate(conf["store_layers"], start=start):
+            print("Creating layer", num, "from paths:", store_layer,
+                  file=sys.stderr)
+            info = add_layer_dir(tar, store_layer, store_dir, mtime=mtime)
+            layers.append(info)
+
+        print("Creating layer", len(layers) + 1, "with customisation...",
+              file=sys.stderr)
+        layers.append(
+          add_customisation_layer(
+            tar,
+            conf["customisation_layer"],
+            mtime=mtime
+          )
+        )
+
+        print("Adding manifests...", file=sys.stderr)
+
+        image_json = {
+            "created": datetime.isoformat(created),
+            "architecture": conf["architecture"],
+            "os": "linux",
+            "config": overlay_base_config(from_image, conf["config"]),
+            "rootfs": {
+                "diff_ids": [f"sha256:{layer.checksum}" for layer in layers],
+                "type": "layers",
+            },
+            "history": [
+                {
+                  "created": datetime.isoformat(created),
+                  "comment": f"store paths: {layer.paths}"
+                }
+                for layer in layers
+            ],
+        }
+
+        image_json = json.dumps(image_json, indent=4).encode("utf-8")
+        image_json_checksum = hashlib.sha256(image_json).hexdigest()
+        image_json_path = f"{image_json_checksum}.json"
+        add_bytes(tar, image_json_path, image_json, mtime=mtime)
+
+        manifest_json = [
+            {
+                "Config": image_json_path,
+                "RepoTags": [conf["repo_tag"]],
+                "Layers": [layer.path for layer in layers],
+            }
+        ]
+        manifest_json = json.dumps(manifest_json, indent=4).encode("utf-8")
+        add_bytes(tar, "manifest.json", manifest_json, mtime=mtime)
+
+        print("Done.", file=sys.stderr)
+
+
+if __name__ == "__main__":
+    main()
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index afef79185f..0bfd011ad4 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.
 ;;;
@@ -45,6 +46,7 @@ (define-module (gnu system image)
   #:use-module (gnu system uuid)
   #:use-module (gnu system vm)
   #:use-module (guix packages)
+  #:use-module ((gnu packages) #:select (search-auxiliary-file))
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages bootloaders)
@@ -58,6 +60,7 @@ (define-module (gnu system image)
   #:use-module (gnu packages hurd)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages mtools)
+  #:use-module (gnu packages python)
   #:use-module (gnu packages virtualization)
   #:use-module ((srfi srfi-1) #:prefix srfi-1:)
   #:use-module (srfi srfi-11)
@@ -78,6 +81,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 +93,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 +172,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 +246,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 +647,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 +695,11 @@ (define builder
               (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 +719,34 @@ (define builder
                                            #: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")
+                                             #+(file-append python "/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
+                                         #:stream-layered-image
+                                         #$stream-layered-image.py)
+                                   '()))))))))
 
     (computed-file name builder
                    ;; Allow offloading so that this I/O-intensive process
@@ -720,6 +755,21 @@ (define builder
                    #:options `(#:references-graphs ((,graph ,os))
                                #:substitutable? ,substitutable?))))
 
+(define stream-layered-image.py
+  (local-file (search-auxiliary-file "python/stream-layered-image.py")))
+
+(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 +861,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 +998,8 @@ (define target (cond
                                        ("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 0276e398a7..85c5f178b5 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-2022 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
@@ -309,3 +311,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..f1adad26dc 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.
 ;;;
@@ -24,10 +25,14 @@ (define-module (guix docker)
   #:use-module (guix base16)
   #:use-module (guix build pack)
   #:use-module ((guix build utils)
-                #:select (mkdir-p
+                #:select (%store-directory
+                          mkdir-p
                           delete-file-recursively
+                          dump-port
                           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 +43,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.
@@ -136,6 +144,9 @@ (define directive-file
     (('directory name _ ...)
      (string-trim name #\/))))
 
+(define %docker-image-max-layers
+  100)
+
 (define* (build-docker-image image paths prefix
                              #:key
                              (repository "guix")
@@ -146,11 +157,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))
+                             stream-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 +185,13 @@ (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.
+
+STREAM-LAYERED-IMAGE is a Python script which accepts a JSON configuration
+file and prints archive to STDOUT.
+
+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
@@ -183,6 +202,39 @@ (define (sanitize path-fragment)
      ;; We also need to escape "/" because we use it as a delimiter.
      "/*.^$[]\\"
      #\\))
+  (define (file-sha256 file-name)
+    "Calculate the hexdigest of the sha256 checksum of FILE-NAME and return 
it."
+    (let ((port (open-pipe* OPEN_READ
+                            "sha256sum"
+                            "--"
+                            file-name)))
+      (let ((result (read-delimited " " port)))
+        (close-pipe port)
+        result)))
+  (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 transformation->replacement
     (match-lambda
       ((old '-> new)
@@ -205,7 +257,9 @@ (define transformation-options
         `("--transform" ,(transformations->expression transformations))))
   (let* ((directory "/tmp/docker-image") ;temporary working directory
          (id (docker-id prefix))
-         (time (date->string (time-utc->date creation-time) "~4"))
+         (time ;Workaround for Python datetime.fromisoformat does not parse Z.
+          (string-append (date->string (time-utc->date creation-time) "~5")
+                         "+00:00"))
          (arch (let-syntax ((cond* (syntax-rules ()
                                      ((_ (pattern clause) ...)
                                       (cond ((string-prefix? pattern system)
@@ -218,7 +272,8 @@ (define transformation-options
                         ("i686"    "386")
                         ("arm"     "arm")
                         ("aarch64" "arm64")
-                        ("mips64"  "mips64le")))))
+                        ("mips64"  "mips64le"))))
+         (paths (if stream-layered-image (paths-split-sort paths) paths)))
     ;; Make sure we start with a fresh, empty working directory.
     (mkdir directory)
     (with-directory-excursion directory
@@ -229,26 +284,38 @@ (define transformation-options
         (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 stream-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
@@ -263,22 +330,65 @@ (define transformation-options
           (lambda ()
             (system* "tar" "--delete" "/" "-f" "layer.tar")))
 
-        (delete-file-recursively "extra"))
+        (when stream-layered-image
+          (call-with-output-file "checksum"
+            (lambda (port)
+              (display (file-sha256 "layer.tar") port)))))
 
       (with-output-to-file "config.json"
         (lambda ()
-          (scm->json (config (string-append id "/layer.tar")
-                             time arch
-                             #:environment environment
-                             #:entry-point entry-point))))
+          (scm->json
+           (if stream-layered-image
+               `(("created" . ,time)
+                 ("repo_tag" . "guix:latest")
+                 ("customisation_layer" . ,id)
+                 ("store_layers" . ,(match paths
+                                      (((head ...) (tail ...))
+                                       (list->vector
+                                        (reverse
+                                         (cons (list->vector tail)
+                                               (fold (lambda (path paths)
+                                                       (cons (vector path) 
paths))
+                                                     '()
+                                                     head)))))))
+                 ("store_dir" . ,(%store-directory))
+                 ("from_image" . #nil)
+                 ("os" . "linux")
+                 ("config"
+                  (env . ,(list->vector (map (match-lambda
+                                               ((name . value)
+                                                (string-append name "=" 
value)))
+                                             environment)))
+                  ,@(if entry-point
+                        `((entrypoint . ,(list->vector entry-point)))
+                        '()))
+                 ("architecture" . ,arch))
+               (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 (repositories prefix id repository))))
+      (if stream-layered-image
+          (let ((input (open-pipe* OPEN_READ "python3"
+                                   stream-layered-image
+                                   "config.json")))
+            (call-with-output-file "image.tar"
+              (lambda (output)
+                (dump-port input output)))
+            (if (eqv? 0 (status:exit-val (close-pipe input)))
+                (begin
+                  (invoke "gzip" "image.tar")
+                  (copy-file "image.tar.gz" image))
+                (error
+                 (formatted-message
+                  (G_ "failed to create ~a image tarball")
+                  image))))
+          (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 25ac9d29d0..3a8f87e850 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 python)
+  #: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
@@ -589,6 +594,10 @@ (define (mksquashfs args)
 ;;;
 ;;; Docker image format.
 ;;;
+
+(define stream-layered-image.py
+  (local-file (search-auxiliary-file "python/stream-layered-image.py")))
+
 (define* (docker-image name profile
                        #:key target
                        (profile-name "guix-profile")
@@ -597,12 +606,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,25 +664,37 @@ (define directives
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
-            (setenv "PATH" #+(file-append archiver "/bin"))
-
-            (build-docker-image #$output
-                                (map store-info-item
-                                     (call-with-input-file "profile"
-                                       read-reference-graph))
-                                #$profile
-                                #:repository (manifest->friendly-name
-                                              (profile-manifest #$profile))
-                                #:database #+database
-                                #:system (or #$target %host-type)
-                                #:environment environment
-                                #:entry-point
-                                #$(and entry-point
-                                       #~(list (string-append #$profile "/"
-                                                              #$entry-point)))
-                                #:extra-files directives
-                                #:compressor #+(compressor-command compressor)
-                                #:creation-time (make-time time-utc 0 1))))))
+            (setenv "PATH"
+                    (string-join `(#+(file-append archiver "/bin")
+                                   #+@(if layered-image?
+                                          (list (file-append coreutils "/bin")
+                                                (file-append gzip "/bin")
+                                                (file-append python "/bin"))
+                                          '()))
+                                 ":"))
+
+            (apply build-docker-image
+                   (append (list #$output
+                                 (map store-info-item
+                                      (call-with-input-file "profile"
+                                        read-reference-graph))
+                                 #$profile
+                                 #:repository (manifest->friendly-name
+                                               (profile-manifest #$profile))
+                                 #:database #+database
+                                 #:system (or #$target %host-type)
+                                 #:environment environment
+                                 #:entry-point
+                                 #$(and entry-point
+                                        #~(list (string-append #$profile "/"
+                                                               #$entry-point)))
+                                 #:extra-files directives
+                                 #:compressor #+(compressor-command compressor)
+                                 #:creation-time (make-time time-utc 0 1))
+                           (if #$layered-image?
+                               (list #:stream-layered-image
+                                     #$stream-layered-image.py)
+                               '())))))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
@@ -679,6 +702,33 @@ (define directives
                     #: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.
@@ -1355,6 +1405,7 @@ (define %formats
   `((tarball . ,self-contained-tarball)
     (squashfs . ,squashfs-image)
     (docker  . ,docker-image)
+    (docker-layered  . ,docker-layered-image)
     (deb . ,debian-archive)
     (rpm . ,rpm-archive)))
 
@@ -1363,15 +1414,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 save-provenance?
          (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 87187bb62c..db2208d91c 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)
@@ -246,6 +248,52 @@ (define bin
                             (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






reply via email to

[Prev in Thread] Current Thread [Next in Thread]