From patchwork Wed May 31 08:47:53 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Oleg Pykhalov X-Patchwork-Id: 50513 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id A265E27BBEB; Wed, 31 May 2023 09:50:03 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.7 required=5.0 tests=BAYES_00,DKIM_ADSP_CUSTOM_MED, DKIM_INVALID,DKIM_SIGNED,FREEMAIL_FROM,MAILING_LIST_MULTI, SPF_HELO_PASS autolearn=ham autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id C164027BBE2 for ; Wed, 31 May 2023 09:49:59 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1q4HWf-0000Mn-Ps; Wed, 31 May 2023 04:49:49 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1q4HW1-0008BT-Q4 for guix-patches@gnu.org; Wed, 31 May 2023 04:49:12 -0400 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1q4HVu-0006qT-9I for guix-patches@gnu.org; Wed, 31 May 2023 04:49:09 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1q4HVu-0007Ov-5H for guix-patches@gnu.org; Wed, 31 May 2023 04:49:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#62153] [PATCH] guix: docker: Build layered image. Resent-From: Oleg Pykhalov Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Wed, 31 May 2023 08:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 62153 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 62153@debbugs.gnu.org Cc: Oleg Pykhalov Received: via spool by 62153-submit@debbugs.gnu.org id=B62153.168552291628404 (code B ref 62153); Wed, 31 May 2023 08:49:02 +0000 Received: (at 62153) by debbugs.gnu.org; 31 May 2023 08:48:36 +0000 Received: from localhost ([127.0.0.1]:34847 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1q4HVT-0007O2-2l for submit@debbugs.gnu.org; Wed, 31 May 2023 04:48:36 -0400 Received: from mail-lf1-f47.google.com ([209.85.167.47]:39281) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1q4HVN-0007NI-0q for 62153@debbugs.gnu.org; Wed, 31 May 2023 04:48:33 -0400 Received: by mail-lf1-f47.google.com with SMTP id 2adb3069b0e04-4f3b03358e9so896236e87.1 for <62153@debbugs.gnu.org>; Wed, 31 May 2023 01:48:28 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20221208; t=1685522902; x=1688114902; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=UJJST3rnJWZsshyWjybCclOol2Vy0Lxza5SzzsyuvOs=; b=FOit0MlRYK0qYOVLhVpV1SdhwTxQGI/Hr05W3oxvHGKguveo8AOOb1MEIWqKiv/ArB PFqRcbpELFSJIDE3nxFppbp9acwQGd0EMYTU8Q6mtBHihRWuYSSvx8r+dO3EcKAZLXTZ vZgr3bvoJrDs8RwDD2KQQ/twlYcOqBEBFVS7WGlRWJ99MRA5VWvrSsxC+I+drtqeCHuX rXINnxEw4pzGoPP+1fBGfqMlyPLq2YD9sUTFoUJ6qZPgZO9SKxOPV0jgAKjc+zD8ALAx /F2+enNNtehuEVELfkhVHPHznCyMhwT254hfDXlvaW+iCOIrLAgQl4lADnQhtffBDWwQ ixig== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1685522902; x=1688114902; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=UJJST3rnJWZsshyWjybCclOol2Vy0Lxza5SzzsyuvOs=; b=QBNRpV1mUh8E77xcxm3cu+Bm1qwhGdOfjRD6pq7wGMZaqNwbqZJXw0mHM+X/uPYnxZ fQFeK9nLK+cf3vDCBaRBLkAKz5A2/SszPe7K5yXaKHMnEK8RgHZm0mKgrsCgJkmaDS7k dVSwp8YeNGJSW4DRwsKrAGEGHDj2qTCvivr/Z3D4rgpwiUIP882snYMN/FTfnWCQp+v+ JMaLrVw1wBTE0sNFjXY+CLuclDVSsukno3cgBkFsPhG1pW/jBwB26WePRZnGC0kDoQPs W2RjaMK+QEMxI2rKfEEtx/GxaxlSLJcXBTs7trS3vQD/8RhLBfNNRDDea7lnI9OoHQBR nY+g== X-Gm-Message-State: AC+VfDxxhfy8UA0EJLAomsyO+XzFM5Go+p47MSmh+m5/Q1Xlu1kCow3J K8lFJawCwLjZ9RVO/C0GsCHyrpazzUI= X-Google-Smtp-Source: ACHHUZ7wZ8y+6+dgeowGue23Hjexqn+EBU/0YPh7QFjtA50Cgk2su32hAhMFmZeweUhzWg2Pzl2Nlg== X-Received: by 2002:ac2:53b5:0:b0:4f3:a4fc:6283 with SMTP id j21-20020ac253b5000000b004f3a4fc6283mr632826lfh.3.1685522901774; Wed, 31 May 2023 01:48:21 -0700 (PDT) Received: from guixsd.wugi.info ([88.201.161.72]) by smtp.gmail.com with ESMTPSA id m9-20020ac24ac9000000b004f3886a63d1sm620295lfp.298.2023.05.31.01.48.21 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 31 May 2023 01:48:21 -0700 (PDT) From: Oleg Pykhalov Date: Wed, 31 May 2023 11:47:53 +0300 Message-Id: X-Mailer: git-send-email 2.38.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * doc/guix.texi (Invoking guix pack): Document docker-layered format. (image Reference): Same. (image-type Reference): Document docker-layered-image-type. * gnu/image.scm (validate-image-format)[docker-layered]: New image format. * gnu/system/image.scm (docker-layered-image, docker-layered-image-type): New variables. (system-docker-image)[layered-image?]: New argument. (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. * 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. * 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. * tests/pack.scm: Add "docker-layered-image + localstatedir" test. --- doc/guix.texi | 18 +++- gnu/image.scm | 3 +- gnu/system/image.scm | 76 +++++++++++---- gnu/tests/docker.scm | 20 +++- guix/docker.scm | 205 +++++++++++++++++++++++++++++++--------- guix/scripts/pack.scm | 62 ++++++++++-- guix/scripts/system.scm | 11 ++- tests/pack.scm | 48 ++++++++++ 8 files changed, 366 insertions(+), 77 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 5fd2449ed5..1c95ec4320 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -56,7 +56,7 @@ 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@* @@ -6984,9 +6984,15 @@ Invoking guix pack 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} @@ -44309,6 +44315,8 @@ image Reference @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. @@ -44644,6 +44652,10 @@ image-type Reference 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 +;;; Copyright © 2023 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -152,7 +153,7 @@ (define-syntax-rule (define-set-sanitizer name field set) ;; 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/system/image.scm b/gnu/system/image.scm index afef79185f..3a502f19ec 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2022 Pavel Shlyak ;;; Copyright © 2022 Denis 'GNUtoo' Carikli ;;; Copyright © 2022 Alex Griffin +;;; Copyright © 2023 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -78,6 +79,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 +91,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 +170,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 +244,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 +645,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 +693,11 @@ (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)) + (guix store database) + (ice-9 receive)) ;; Set the SQL schema location. (sql-schema #$schema) @@ -700,18 +717,31 @@ (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 #$layered-image? + (setenv "PATH" + (string-join (list #+(file-append archiver "/bin") + #+(file-append coreutils "/bin") + #+(file-append gzip "/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 + #:layered-image? #$layered-image?) + '())))))))) (computed-file name builder ;; Allow offloading so that this I/O-intensive process @@ -720,6 +750,18 @@ (define* (system-docker-image image #:options `(#:references-graphs ((,graph ,os)) #:substitutable? ,substitutable?)))) +(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 +853,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 +990,8 @@ (define* (system-image image) ("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 edc9804414..0cccc02ad2 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 ;;; Copyright © 2019-2023 Ludovic Courtès +;;; Copyright © 2023 Oleg Pykhalov ;;; ;;; 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 @@ -316,3 +318,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..e10b940aa4 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès ;;; Copyright © 2018 Chris Marusich ;;; Copyright © 2021 Maxim Cournoyer +;;; Copyright © 2023 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +29,8 @@ (define-module (guix docker) delete-file-recursively 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 +41,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. @@ -92,12 +98,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 +112,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 +131,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 +142,37 @@ (define directive-file (('directory name _ ...) (string-trim name #\/)))) +(define %docker-image-max-layers + 100) + +(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 (create-empty-tar file) + (invoke "tar" "-cf" file "--files-from" "/dev/null")) + (define* (build-docker-image image paths prefix #:key (repository "guix") @@ -146,11 +183,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)) + 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 +211,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 LAYERED-IMAGE? is true 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 +249,53 @@ (define* (build-docker-image image paths prefix (if (eq? '() transformations) '() `("--transform" ,(transformations->expression transformations)))) + (define layers-hashes + (match-lambda + (((head ...) (tail ...) id) + (create-empty-tar "image.tar") + (let* ((head-layers + (map + (lambda (file) + (invoke "tar" "cf" "layer.tar" file) + (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)) + 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 +322,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 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 @@ -261,24 +367,33 @@ (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 layered-image? + (layers-hashes (append (paths-split-sort paths) + (list id))) + (list (layer-diff-id (string-append id "/layer.tar")))) + time arch + #:environment environment + #:entry-point entry-point)))) + (if layered-image? + (begin + (invoke "tar" "-rf" "image.tar" "config.json") + (apply invoke `(,@compressor "image.tar")) + (copy-file "image.tar.gz" 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))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 0dc9979194..3fefd2eac3 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer ;;; Copyright © 2020 Eric Bavier ;;; Copyright © 2022 Alex Griffin +;;; Copyright © 2023 Oleg Pykhalov ;;; ;;; 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 shells) + #: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 @@ -597,12 +602,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,7 +660,13 @@ (define* (docker-image name profile `((directory "/tmp" ,(getuid) ,(getgid) #o1777) ,@(append-map symlink->directives '#$symlinks))) - (setenv "PATH" #+(file-append archiver "/bin")) + (setenv "PATH" + (string-join `(#+(file-append archiver "/bin") + #+@(if layered-image? + (list (file-append coreutils "/bin") + (file-append gzip "/bin")) + '())) + ":")) (build-docker-image #$output (map store-info-item @@ -671,7 +684,8 @@ (define* (docker-image name profile #$entry-point))) #:extra-files directives #:compressor #+(compressor-command compressor) - #:creation-time (make-time time-utc 0 1)))))) + #:creation-time (make-time time-utc 0 1) + #:layered-image? #$layered-image?))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) @@ -679,6 +693,33 @@ (define* (docker-image name profile #: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. @@ -1353,6 +1394,7 @@ (define %formats `((tarball . ,self-contained-tarball) (squashfs . ,squashfs-image) (docker . ,docker-image) + (docker-layered . ,docker-layered-image) (deb . ,debian-archive) (rpm . ,rpm-archive))) @@ -1361,15 +1403,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 ;;; Copyright © 2021 Simon Tournier ;;; Copyright © 2022 Tobias Geerinckx-Rice +;;; Copyright © 2023 Oleg Pykhalov ;;; ;;; 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 (process-action action args opts) (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 ce5a2f8a53..432ab1b2ea 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2021, 2023 Maxim Cournoyer +;;; Copyright © 2023 Oleg Pykhalov ;;; ;;; 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) @@ -250,6 +252,52 @@ (define rpm-for-tests (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