[bug#62153] [PATCH 4/5] guix: pack: Build layered images.

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

* guix/scripts/pack.scm (docker-image, guix-pack, %default-options,
%docker-format-options, show-docker-format-options/detailed): Handle
'--max-layers' option.
* doc/guix.texi (Invoking guix pack): Document this.

Change-Id: I90660b2421fcdde891f003469fe2e2edaac7da41
---
 doc/guix.texi         | 26 ++++++++++++++++++++++-
 guix/scripts/pack.scm | 38 ++++++++++++++++++++++++++-------
 tests/pack.scm        | 49 +++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 104 insertions(+), 9 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index cca250dc31..d21048405a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -56,7 +56,7 @@
 Copyright @copyright{} 2017, 2018, 2019, 2020, 2023 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@*
@@ -7441,6 +7441,30 @@ Invoking guix pack
 guix pack -f docker --entry-point=bin/guile --entry-point-argument="--help" guile
 @end example
 
+@cindex maximum layers argument, for docker images
+@item --max-layers=@code{n}
+Specifies the maximum number of Docker image layers allowed when
+building an image.
+
+@example
+guix pack -f docker --max-layers=100 guile
+@end example
+
+This option allows you to limit the number of layers in a Docker image.
+Docker images are comprised of multiple layers, and each layer adds to
+the overall size and complexity of the image.  By setting a maximum
+number of layers, you can control the following effects:
+
+@itemize
+@item Disk Usage:
+Increasing the number of layers can help optimize the disk space
+required to store multiple images built with a similar package graph.
+
+@item Pulling:
+When transferring images between different nodes or systems, having more
+layers can reduce the time required to pull the image.
+@end itemize
+
 @item --expression=@var{expr}
 @itemx -e @var{expr}
 Consider the package @var{expr} evaluates to.
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 4c0a602eb1..22f0dd6061 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -9,6 +9,7 @@
 ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
 ;;; Copyright © 2023 Graham James Addis <graham@addis.org.uk>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -48,6 +49,7 @@ (define-module (guix scripts pack)
   #:use-module (guix scripts build)
   #:use-module (guix transformations)
   #:use-module ((guix self) #:select (make-config.scm))
+  #:use-module ((guix docker) #:select (%docker-image-max-layers))
   #:use-module (gnu compression)
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
@@ -517,12 +519,15 @@ (define* (docker-image name profile
                        localstatedir?
                        (symlinks '())
                        (archiver tar)
-                       (extra-options '()))
+                       (extra-options '())
+                       max-layers)
   "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.  EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument."
+the image.  EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument.
+If MAX-LAYERS is not false, 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))
@@ -583,11 +588,17 @@ (define* (docker-image name profile
                        (cons* (string-append prefix "/" entry-point)
 		              entry-point-argument))))
 
-            (setenv "PATH" #+(file-append archiver "/bin"))
+            (setenv "PATH"
+                    (string-join `(#+(file-append archiver "/bin")
+                                   #+@(if max-layers
+                                          (list (file-append gzip "/bin"))
+                                          '()))
+                                 ":"))
 
             (let-keywords '#$extra-options #f
                           ((image-tag #f)
-                           (entry-point-argument #f))
+                           (entry-point-argument #f)
+                           (max-layers #f))
 
               (build-docker-image #$output
                                   (map store-info-item
@@ -609,7 +620,8 @@ (define* (docker-image name profile
                                   #:compressor
                                   #+(compressor-command compressor)
                                   #:creation-time
-                                  (make-time time-utc 0 1)))))))
+                                  (make-time time-utc 0 1)
+                                  #:max-layers max-layers))))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
@@ -1287,6 +1299,7 @@ (define %default-options
     (verbosity . 1)
     (symlinks . ())
     (entry-point-argument . ())
+    (max-layers . ,%docker-image-max-layers)
     (compressor . ,(first %compressors))))
 
 (define %formats
@@ -1324,7 +1337,11 @@ (define (required-option symbol)
 (define %docker-format-options
   (list (required-option 'image-tag)
         (option '(#\A "entry-point-argument") #t #f
-                entry-point-argument-spec-option-parser)))
+                entry-point-argument-spec-option-parser)
+        (option '("max-layers") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'max-layers (string->number* arg)
+                              result)))))
 
 (define (show-docker-format-options)
   (display (G_ "
@@ -1338,7 +1355,10 @@ (define (show-docker-format-options/detailed)
       -A, --entry-point-argument=COMMAND/PARAMETER
                          Value(s) to use for the Docker EntryPoint arguments.
                          Multiple instances are accepted. This is only valid
-                         in conjunction with the --entry-point option"))
+                         in conjunction with the --entry-point option
+
+      --max-layers=N
+                         Number of image layers"))
   (newline)
   (exit 0))
 
@@ -1651,7 +1671,9 @@ (define-command (guix-pack . args)
                                      (list #:image-tag
                                            (assoc-ref opts 'image-tag)
                                            #:entry-point-argument
-                                           (assoc-ref opts 'entry-point-argument)))
+                                           (assoc-ref opts 'entry-point-argument)
+                                           #:max-layers
+                                           (assoc-ref opts 'max-layers)))
                                     ('deb
                                      (list #:control-file
                                            (process-file-arg opts 'control-file)
diff --git a/tests/pack.scm b/tests/pack.scm
index ac78817a70..fda4dc04c6 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017-2021, 2023 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 (libc-utf8-locales-for-target))
   #:use-module (gnu packages bootstrap)
@@ -250,6 +252,53 @@ (define rpm-for-tests
                            (mkdir #$output)))))))
       (built-derivations (list check))))
 
+  (unless store (test-skip 1))
+  (test-assertm "docker-layered-image + localstatedir"
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile -> (profile
+                      (content (packages->manifest (list %bootstrap-guile)))
+                      (hooks '())
+                      (locales? #f)))
+         (tarball (docker-image "docker-pack" profile
+                                #:symlinks '(("/bin/Guile" -> "bin/guile"))
+                                #:localstatedir? #t
+                                #:max-layers 100))
+         (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"
     (mlet* %store-monad
-- 
2.41.0