unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
From: Oleg Pykhalov <go.wigust@gmail.com>
To: 62153@debbugs.gnu.org
Cc: "Oleg Pykhalov" <go.wigust@gmail.com>,
	"Christopher Baines" <guix@cbaines.net>,
	"Josselin Poiret" <dev@jpoiret.xyz>,
	"Ludovic Courtès" <ludo@gnu.org>,
	"Mathieu Othacehe" <othacehe@gnu.org>,
	"Ricardo Wurmus" <rekado@elephly.net>,
	"Simon Tournier" <zimon.toutoune@gmail.com>,
	"Tobias Geerinckx-Rice" <me@tobias.gr>
Subject: [bug#62153] [PATCH 3/5] guix: docker: Build layered images.
Date: Tue, 26 Dec 2023 05:18:55 +0300	[thread overview]
Message-ID: <49f8906ba06af461e17d9badcbbf3967f1a8be3b.1703556298.git.go.wigust@gmail.com> (raw)
In-Reply-To: <cover.1703556298.git.go.wigust@gmail.com>

* guix/docker.scm (%docker-image-max-layers): New variable.
(size-sorted-store-items, create-empty-tar): New procedures.
(config, manifest, build-docker-image): Build layered images.

Change-Id: I4c8846bff0a3ceccb77e6bdf95d4942e5c3efe41
---
 guix/docker.scm | 212 +++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 166 insertions(+), 46 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 5e6460f43f..5deca2afdb 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.
 ;;;
@@ -29,16 +30,27 @@ (define-module (guix docker)
                           with-directory-excursion
                           invoke))
   #:use-module (gnu build install)
+  #:use-module ((guix build store-copy)
+                #:select (file-size))
   #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-71)
   #:use-module ((texinfo string-utils)
                 #:select (escape-special-chars))
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
-  #:export (build-docker-image))
+  #:export (%docker-image-max-layers
+            build-docker-image))
+
+;; The maximum number of layers allowed in a Docker image is typically around
+;; 128, although it may vary depending on the Docker daemon. However, we
+;; recommend setting the limit to 100 to ensure sufficient room for future
+;; extensions.
+(define %docker-image-max-layers
+  #f)
 
 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
 (define docker-id
@@ -92,12 +104,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 +118,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 +137,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 +148,26 @@ (define directive-file
     (('directory name _ ...)
      (string-trim name #\/))))
 
+(define (size-sorted-store-items items max-layers)
+  "Split list of ITEMS at %MAX-LAYERS and sort by disk usage."
+  (let* ((items-length (length items))
+         (head tail
+               (split-at
+                (map (match-lambda ((size . item) item))
+                     (sort (map (lambda (item)
+                                  (cons (file-size item) item))
+                                items)
+                           (lambda (item1 item2)
+                             (< (match item2 ((size . _) size))
+                                (match item1 ((size . _) size))))))
+                (if (>= items-length max-layers)
+                    (- max-layers 2)
+                    (1- items-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 +178,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))
+                             max-layers
+                             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 +206,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 MAX-LAYERS is not false 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 +244,59 @@ (define* (build-docker-image image paths prefix
     (if (eq? '() transformations)
         '()
         `("--transform" ,(transformations->expression transformations))))
+  (define (seal-layer)
+    ;; Add 'layer.tar' to 'image.tar' under the right name.  Return its hash.
+    (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))
+  (define layers-hashes
+    ;; Generate a tarball that includes container image layers as tarballs,
+    ;; along with a manifest.json file describing the layer and config file
+    ;; locations.
+    (match-lambda
+      (((head ...) (tail ...) id)
+       (create-empty-tar "image.tar")
+       (let* ((head-layers
+               (map
+                (lambda (file)
+                  (invoke "tar" "cf" "layer.tar" file)
+                  (seal-layer))
+                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 +323,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 max-layers '() 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 +368,37 @@ (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 max-layers
+                       (layers-hashes
+                        (append (size-sorted-store-items paths max-layers)
+                                (list id)))
+                       (list (layer-diff-id (string-append id "/layer.tar"))))
+                   time arch
+                   #:environment environment
+                   #:entry-point entry-point))))
+      (if max-layers
+          (begin
+            (invoke "tar" "-rf" "image.tar" "config.json")
+            (if compressor
+                (begin
+                  (apply invoke `(,@compressor "image.tar"))
+                  (copy-file "image.tar.gz" image))
+                (copy-file "image.tar" image)))
+          (begin
+            (with-output-to-file "manifest.json"
+              (lambda ()
+                (scm->json (manifest prefix
+                                     (list (string-append id "/layer.tar"))
+                                     repository))))
+            (with-output-to-file "repositories"
+              (lambda ()
+                (scm->json (repositories prefix id repository))))
+            (apply invoke "tar" "-cf" image
+                   `(,@(tar-base-options #:compressor compressor)
+                     ".")))))
     (delete-file-recursively directory)))
-- 
2.41.0





  parent reply	other threads:[~2023-12-26  2:21 UTC|newest]

Thread overview: 42+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2023-03-13  0:30 [bug#62153] [PATCH 0/2] Add Docker layered image for pack and system Oleg Pykhalov
2023-03-13  0:33 ` [bug#62153] [PATCH 1/2] guix: docker: Build layered image Oleg Pykhalov
2023-03-13  0:33   ` [bug#62153] [PATCH 2/2] news: Add entry for the new 'docker-layered' distribution format Oleg Pykhalov
2023-03-13 21:09     ` pelzflorian (Florian Pelz)
2023-03-14  0:24       ` [bug#62153] [PATCH 0/2] Add Docker layered image for pack and system (v2) Oleg Pykhalov
2023-03-14  0:24         ` [bug#62153] [PATCH 1/2] guix: docker: Build layered image Oleg Pykhalov
2023-03-14  0:24         ` [bug#62153] [PATCH 2/2] news: Add entry for the new 'docker-layered' distribution format Oleg Pykhalov
2023-03-13 15:01   ` [bug#62153] [PATCH 1/2] guix: docker: Build layered image Simon Tournier
2023-03-13 21:10     ` Oleg Pykhalov
2023-03-14  8:19       ` Simon Tournier
2023-03-14  9:15         ` Ricardo Wurmus
2023-03-16 10:37           ` Ludovic Courtès
2023-03-20  6:38             ` Oleg Pykhalov
2023-03-20 16:51               ` [bug#62153] [PATCH 0/2] Disarchive vs Gash-Utils for docker-layered Oleg Pykhalov
2023-03-14  9:11     ` [bug#62153] [PATCH 1/2] guix: docker: Build layered image Christopher Baines
2023-03-13  0:43 ` [bug#62153] Cover lever typo in guix pack format example Oleg Pykhalov
2023-03-14  0:40 ` [bug#62153] Missing diff in cover lever for v2 patch Oleg Pykhalov
2023-05-31  8:45 ` [bug#62153] [PATCH] Add Docker layered image for pack and system (v3) Oleg Pykhalov
2023-05-31  8:47   ` [bug#62153] [PATCH] guix: docker: Build layered image Oleg Pykhalov
2023-05-31  8:47   ` [bug#62153] [PATCH] news: Add entry for the new 'docker-layered' distribution format Oleg Pykhalov
2023-05-31 12:53   ` [bug#62153] [PATCH] Add Docker layered image for pack and system (v3) Greg Hogan
2023-05-31 13:14     ` Oleg Pykhalov
2023-06-02 17:02       ` Greg Hogan
2023-06-03 19:10         ` [bug#62153] [PATCH 0/2] Add Docker layered image for pack and system Oleg Pykhalov
2023-06-03 19:14           ` [bug#62153] [PATCH v4 1/2] guix: docker: Build layered image Oleg Pykhalov
2023-12-22 22:10             ` Ludovic Courtès
2023-06-03 19:16           ` [bug#62153] [PATCH v4] news: Add entry for the new 'docker-layered' distribution format Oleg Pykhalov
2023-12-26  2:15 ` [bug#62153] [PATCH v5 0/5] Add Docker layered image for pack and system Oleg Pykhalov
2023-12-26  2:18   ` [bug#62153] [PATCH 1/5] guix: pack: Add '--entry-point-argument' option Oleg Pykhalov
2023-12-27 18:14     ` Mathieu Othacehe
2023-12-27 18:16       ` Mathieu Othacehe
2023-12-26  2:18   ` [bug#62153] [PATCH 2/5] tests: docker-system: Increase image size Oleg Pykhalov
2023-12-26  2:18   ` Oleg Pykhalov [this message]
2023-12-27 20:15     ` [bug#62153] [PATCH 3/5] guix: docker: Build layered images Mathieu Othacehe
2024-01-18 14:55     ` Ludovic Courtès
2023-12-26  2:18   ` [bug#62153] [PATCH 4/5] guix: pack: " Oleg Pykhalov
2023-12-27 20:25     ` Mathieu Othacehe
2023-12-26  2:18   ` [bug#62153] [PATCH 5/5] scripts: system: " Oleg Pykhalov
2023-12-27 20:29     ` Mathieu Othacehe
2024-01-08 16:49       ` Ludovic Courtès
2024-01-09 12:58         ` bug#62153: " Oleg Pykhalov
     [not found] ` <878r9xb2e6.fsf@gmail.com>
     [not found]   ` <875y0p99c4.fsf@gnu.org>
2023-12-26  2:40     ` [bug#62153] Merging guix pack changes for Docker containers packaging Oleg Pykhalov

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://guix.gnu.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=49f8906ba06af461e17d9badcbbf3967f1a8be3b.1703556298.git.go.wigust@gmail.com \
    --to=go.wigust@gmail.com \
    --cc=62153@debbugs.gnu.org \
    --cc=dev@jpoiret.xyz \
    --cc=guix@cbaines.net \
    --cc=ludo@gnu.org \
    --cc=me@tobias.gr \
    --cc=othacehe@gnu.org \
    --cc=rekado@elephly.net \
    --cc=zimon.toutoune@gmail.com \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).