[bug#62153] [PATCH 5/5] scripts: system: Build layered images.

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

* guix/scripts/system.scm (show-help, %docker-format-options, %options,
%default-options, show-docker-format-options,
show-docker-format-options/detailed, process-action): Handle '--max-layers'
option.
* gnu/system/image.scm (system-docker-image): Same.
* gnu/image.scm (<image>)[max-layers]: New record field.

Change-Id: I2726655aefd6688b976057fd5a38e9972ebfc292
---
 gnu/image.scm           |  4 ++++
 gnu/system/image.scm    | 41 ++++++++++++++++++++++++++++-------------
 guix/scripts/system.scm | 28 ++++++++++++++++++++++++++--
 3 files changed, 58 insertions(+), 15 deletions(-)

diff --git a/gnu/image.scm b/gnu/image.scm
index 523653dd77..7fb06dec10 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.
 ;;;
@@ -42,6 +43,7 @@ (define-module (gnu image)
             image-format
             image-platform
             image-size
+            image-max-layers
             image-operating-system
             image-partition-table-type
             image-partitions
@@ -170,6 +172,8 @@ (define-record-type* <image>
   (size               image-size  ;size in bytes as integer
                       (default 'guess)
                       (sanitize validate-size))
+  (max-layers         image-max-layers  ;number of layers as integer
+                      (default #false))
   (operating-system   image-operating-system)  ;<operating-system>
   (partition-table-type image-partition-table-type ; 'mbr or 'gpt
                       (default 'mbr)
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index b825892232..2cc1012893 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
 ;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -686,7 +687,8 @@ (define (image-with-label base-image label)
 
 (define* (system-docker-image image
                               #:key
-                              (name "docker-image"))
+                              (name "docker-image")
+                              (archiver tar))
   "Build a docker image for IMAGE.  NAME is the base name to use for the
 output file."
   (define boot-program
@@ -731,6 +733,7 @@ (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))
@@ -754,18 +757,30 @@ (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 #$(image-max-layers image)
+                  (setenv "PATH"
+                          (string-join (list #+(file-append archiver "/bin")
+                                             #+(file-append gzip "/bin"))
+                                       ":")))
+                (apply build-docker-image
+                       (append (list #$output
+                                     (append (if #$(image-max-layers 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 #$(image-max-layers image)
+                                   (list #:root-system image-root
+                                         #:max-layers #$(image-max-layers image))
+                                   '()))))))))
 
     (computed-file name builder
                    ;; Allow offloading so that this I/O-intensive process
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index f85b663d64..a21ecd4d1e 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -58,6 +58,7 @@ (define-module (guix scripts system)
   #:use-module (guix scripts system reconfigure)
   #:use-module (guix build utils)
   #:use-module (guix progress)
+  #:use-module ((guix docker) #:select (%docker-image-max-layers))
   #:use-module (gnu build image)
   #:use-module (gnu build install)
   #:autoload   (gnu build file-systems)
@@ -1053,6 +1054,8 @@ (define (show-help)
   (newline)
   (show-native-build-options-help)
   (newline)
+  (show-docker-format-options)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
@@ -1060,6 +1063,12 @@ (define (show-help)
   (newline)
   (show-bug-report-information))
 
+(define %docker-format-options
+  (list (option '("max-layers") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'max-layers (string->number* arg)
+                               result)))))
+
 (define %options
   ;; Specifications of the command-line options.
   (cons* (option '(#\h "help") #f #f
@@ -1154,7 +1163,8 @@ (define %options
                    (alist-cons 'list-installed (or arg "") result)))
          (append %standard-build-options
                  %standard-cross-build-options
-                 %standard-native-build-options)))
+                 %standard-native-build-options
+                 %docker-format-options)))
 
 (define %default-options
   ;; Alist of default option values.
@@ -1175,7 +1185,8 @@ (define %default-options
     (label . #f)
     (volatile-image-root? . #f)
     (volatile-vm-root? . #t)
-    (graph-backend . "graphviz")))
+    (graph-backend . "graphviz")
+    (max-layers . ,%docker-image-max-layers)))
 
 (define (verbosity-level opts)
   "Return the verbosity level based on OPTS, the alist of parsed options."
@@ -1183,6 +1194,17 @@ (define (verbosity-level opts)
       (if (eq? (assoc-ref opts 'action) 'build)
           3 1)))
 
+(define (show-docker-format-options)
+  (display (G_ "
+      --help-docker-format list options specific to the docker image type.")))
+
+(define (show-docker-format-options/detailed)
+  (display (G_ "
+      --max-layers=N
+                         Number of image layers"))
+  (newline)
+  (exit 0))
+
 \f
 ;;;
 ;;; Entry point.
@@ -1245,6 +1267,7 @@ (define (process-action action args opts)
                                            ((docker-image) docker-image-type)
                                            (else image-type)))
                             (image-size (assoc-ref opts 'image-size))
+                            (image-max-layers (assoc-ref opts 'max-layers))
                             (volatile?
                              (assoc-ref opts 'volatile-image-root?))
                             (shared-network?
@@ -1258,6 +1281,7 @@ (define (process-action action args opts)
                                       (image-with-label base-image label)
                                       base-image))
                          (size image-size)
+                         (max-layers image-max-layers)
                          (volatile-root? volatile?)
                          (shared-network? shared-network?))))
          (os          (or (image-operating-system image)
-- 
2.41.0