diff options
| -rw-r--r-- | gnu/image.scm | 4 | ||||
| -rw-r--r-- | gnu/system/image.scm | 41 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 31 |
3 files changed, 61 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 @@ image-format image-platform image-size + image-max-layers image-operating-system image-partition-table-type image-partitions @@ -170,6 +172,8 @@ that is not in SET, mentioning FIELD in the error message." (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 @@ returns an image record where the first partition's label is set to <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 @@ output file." (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 @@ output file." #: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..bf3d2f9044 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -58,6 +58,7 @@ #: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 @@ Some ACTIONS support additional ARGS.\n")) (newline) (show-native-build-options-help) (newline) + (show-docker-format-options) + (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -1060,12 +1063,21 @@ Some ACTIONS support additional ARGS.\n")) (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 (lambda args (leave-on-EPIPE (show-help)) (exit 0))) + (option '("help-docker-format") #f #f + (lambda args + (show-docker-format-options/detailed))) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix system"))) @@ -1154,7 +1166,8 @@ Some ACTIONS support additional ARGS.\n")) (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 +1188,8 @@ Some ACTIONS support additional ARGS.\n")) (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 +1197,17 @@ Some ACTIONS support additional ARGS.\n")) (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)) + ;;; ;;; Entry point. @@ -1245,6 +1270,7 @@ resulting from command-line parsing." ((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 +1284,7 @@ resulting from command-line parsing." (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) |