Merge branch 'master' into gnome-team

9 files changed, 512 insertions, 133 deletions

diff --git a/guix/build-system/zig.scm b/guix/build-system/zig.scm
index 215178ceb4..1fa4782a2e 100644
--- a/guix/build-system/zig.scm
+++ b/guix/build-system/zig.scm
@@ -83,6 +83,79 @@
                       #:system system
                       #:guile-for-build guile)))
 
+(define* (zig-cross-build name
+                          #:key
+                          source target
+                          build-inputs target-inputs host-inputs
+                          (phases '%standard-phases)
+                          (outputs '("out"))
+                          (search-paths '())
+                          (native-search-paths '())
+                          (tests? #t)
+                          (test-target #f)
+                          (zig-build-flags ''())
+                          (zig-test-flags ''())
+                          (zig-destdir "out")
+                          (zig-test-destdir "test-out")
+                          (zig-release-type #f)
+                          (system (%current-system))
+                          (guile #f)
+                          (imported-modules %zig-build-system-modules)
+                          (modules '((guix build zig-build-system)
+                                     (guix build utils))))
+  "Build SOURCE using Zig, and with INPUTS."
+  (define builder
+    (with-imported-modules imported-modules
+      #~(begin
+          (use-modules #$@(sexp->gexp modules))
+
+          (define %build-host-inputs
+            #+(input-tuples->gexp build-inputs))
+
+          (define %build-target-inputs
+            (append #$(input-tuples->gexp host-inputs)
+              #+(input-tuples->gexp target-inputs)))
+
+          (define %build-inputs
+            (append %build-host-inputs %build-target-inputs))
+
+          (define %outputs
+            #$(outputs->gexp outputs))
+
+          (zig-build #:name #$name
+                     #:source #+source
+                     #:system #$system
+                     #:phases #$phases
+                     #:outputs %outputs
+                     #:target #$target
+                     #:test-target #$test-target
+                     #:inputs %build-target-inputs
+                     #:native-inputs %build-host-inputs
+                     #:search-paths '#$(map search-path-specification->sexp
+                                            search-paths)
+                     #:native-search-paths '#$(map
+                                                search-path-specification->sexp
+                                                native-search-paths)
+                     #:zig-build-flags #$zig-build-flags
+                     #:zig-test-flags #$zig-test-flags
+                     #:zig-release-type #$zig-release-type
+                     #:zig-destdir #$zig-destdir
+                     #:zig-test-destdir #$zig-test-destdir
+                     #:tests? #$tests?
+                     #:search-paths '#$(sexp->gexp
+                                        (map search-path-specification->sexp
+                                             search-paths))))))
+
+  (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
+                                                  system #:graft? #f)))
+        (gexp->derivation name builder
+                          #:system system
+                          #:target target
+                          #:graft? #f
+                          #:substitutable? substitutable?
+                          #:guile-for-build guile)))
+
+
 (define* (lower name
                 #:key source inputs native-inputs outputs system target
                 (zig (default-zig))
@@ -93,27 +166,30 @@
   (define private-keywords
     '(#:target #:zig #:inputs #:native-inputs #:outputs))
 
-  ;; TODO: support cross-compilation
-  ;; It's as simple as adding some build flags to `zig-build-flags`
-  ;; -Dtarget=aarch64-linux-musl, for example.
-  (and (not target)
-       (bag
-         (name name)
-         (system system)
-         (target target)
-         (host-inputs `(,@(if source
-                              `(("source" ,source))
-                              '())
-                        ,@inputs
-
-                        ;; Keep the standard inputs of 'gnu-build-system'
-                        ;; TODO: do we need this?
-                        ,@(standard-packages)))
-         (build-inputs `(("zig" ,zig)
-                         ,@native-inputs))
-         (outputs outputs)
-         (build zig-build)
-         (arguments (strip-keyword-arguments private-keywords arguments)))))
+  (bag
+    (name name)
+    (system system)
+    (target target)
+    (build-inputs `(,@(if source
+                        `(("source" ,source))
+                        '())
+                    ,@`(("zig" ,zig))
+                    ,@native-inputs
+                    ,@(if target '() inputs)
+                    ,@(if target
+                        ;; Use the standard cross inputs of
+                        ;; 'gnu-build-system'.
+                        (standard-cross-packages target 'host)
+                        '())
+                    ;; Keep the standard inputs of 'gnu-build-system'.
+                    ,@(standard-packages)))
+    (host-inputs (if target inputs '()))
+    (target-inputs (if target
+                     (standard-cross-packages target 'target)
+                     '()))
+    (outputs outputs)
+    (build (if target zig-cross-build zig-build))
+    (arguments (strip-keyword-arguments private-keywords arguments))))
 
 (define zig-build-system
   (build-system
diff --git a/guix/build/zig-build-system.scm b/guix/build/zig-build-system.scm
index d414ebfb17..8352a73324 100644
--- a/guix/build/zig-build-system.scm
+++ b/guix/build/zig-build-system.scm
@@ -47,6 +47,7 @@
                 zig-build-flags
                 zig-release-type       ;; "safe", "fast" or "small" empty for a
                                        ;; debug build"
+                target
                 #:allow-other-keys)
   "Build a given Zig package."
 
@@ -56,6 +57,9 @@
                      "--prefix-lib-dir"     "lib"
                      "--prefix-exe-dir"     "bin"
                      "--prefix-include-dir" "include"
+                     ,@(if target
+                         (list (string-append "-Dtarget=" target))
+                         '())
                      ,@(if zig-release-type
                          (list (string-append "-Drelease-" zig-release-type))
                          '())
@@ -65,9 +69,10 @@
 
 (define* (check #:key tests?
                 zig-test-flags
+                target
                 #:allow-other-keys)
   "Run all the tests"
-  (when tests?
+  (when (and tests? (not target))
     (let ((old-destdir (getenv "DESTDIR")))
       (setenv "DESTDIR" "test-out") ;; Avoid colisions with the build output
       (let ((call `("zig" "build" "test"
diff --git a/guix/docker.scm b/guix/docker.scm
index 5e6460f43f..1c6f59568f 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 @@
                           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 @@ Return a version of TAG that follows these rules."
                       (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 @@ Return a version of TAG that follows these rules."
   `((,(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 @@ Return a version of TAG that follows these rules."
     (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 @@ Return a version of TAG that follows these rules."
     (('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 @@ Return a version of TAG that follows these rules."
                              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 @@ non-empty directory, then its contents will be recursively added, as well.
 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 store paths splitted in their own layers 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 @@ SRFI-19 time-utc object, as the creation time in metadata."
     (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 @@ SRFI-19 time-utc object, as the creation time in metadata."
         (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 @@ SRFI-19 time-utc object, as the creation time in metadata."
         ;; 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)))
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 43823d006e..c57bd0bc6a 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2023 David Elsing <david.elsing@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,12 +26,15 @@
 (define-module (guix import crate)
   #:use-module (guix base32)
   #:use-module (guix build-system cargo)
+  #:use-module (guix diagnostics)
   #:use-module (gcrypt hash)
   #:use-module (guix http-client)
+  #:use-module (guix i18n)
   #:use-module (guix import json)
   #:use-module (guix import utils)
   #:use-module (guix memoization)
   #:use-module (guix packages)
+  #:use-module (guix read-print)
   #:use-module (guix upstream)
   #:use-module (guix utils)
   #:use-module (gnu packages)
@@ -40,6 +44,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-69)
   #:use-module (srfi srfi-71)
   #:export (crate->guix-package
             guix-package->crate-name
@@ -99,7 +104,7 @@
 
 ;; Autoload Guile-Semver so we only have a soft dependency.
 (module-autoload! (current-module)
-		  '(semver) '(string->semver semver->string semver<?))
+		  '(semver) '(string->semver semver->string semver<? semver=?))
 (module-autoload! (current-module)
 		  '(semver ranges) '(string->semver-range semver-range-contains?))
 
@@ -164,16 +169,18 @@ record or #f if it was not found."
         (list-matches "^(0+\\.){,2}[0-9]+" version))))
 
 (define* (make-crate-sexp #:key name version cargo-inputs cargo-development-inputs
-                          home-page synopsis description license build?)
+                          home-page synopsis description license build? yanked?)
   "Return the `package' s-expression for a rust package with the given NAME,
 VERSION, CARGO-INPUTS, CARGO-DEVELOPMENT-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION,
 and LICENSE."
   (define (format-inputs inputs)
     (map
      (match-lambda
-      ((name version)
+      ((name version yanked)
        (list (crate-name->package-name name)
-             (version->semver-prefix version))))
+             (if yanked
+                 (string-append version "-yanked")
+                 (version->semver-prefix version)))))
      inputs))
 
   (let* ((port (http-fetch (crate-uri name version)))
@@ -183,6 +190,9 @@ and LICENSE."
          (pkg `(package
                    (name ,guix-name)
                    (version ,version)
+                   ,@(if yanked?
+                         `(,(comment "; This version was yanked!\n" #t))
+                         '())
                    (source (origin
                              (method url-fetch)
                              (uri (crate-uri ,name version))
@@ -190,6 +200,9 @@ and LICENSE."
                              (sha256
                               (base32
                                ,(bytevector->nix-base32-string (port-sha256 port))))))
+                   ,@(if yanked?
+                         `((properties '((crate-version-yanked? . #t))))
+                         '())
                    (build-system cargo-build-system)
                    ,@(maybe-arguments (append (if build?
                                                  '()
@@ -206,7 +219,10 @@ and LICENSE."
                                ((license) license)
                                (_ `(list ,@license)))))))
          (close-port port)
-         (package->definition pkg (version->semver-prefix version))))
+         (package->definition pkg
+                              (if yanked?
+                                  (string-append version "-yanked")
+                                  (version->semver-prefix version)))))
 
 (define (string->license string)
   (filter-map (lambda (license)
@@ -217,13 +233,14 @@ and LICENSE."
                          'unknown-license!)))
               (string-split string (string->char-set " /"))))
 
-(define* (crate->guix-package crate-name #:key version include-dev-deps?
-                              #:allow-other-keys)
+(define* (crate->guix-package
+          crate-name
+          #:key version include-dev-deps? allow-yanked? #:allow-other-keys)
   "Fetch the metadata for CRATE-NAME from crates.io, and return the
 `package' s-expression corresponding to that package, or #f on failure.
 When VERSION is specified, convert it into a semver range and attempt to fetch
 the latest version matching this semver range; otherwise fetch the latest
-version of CRATE-NAME. If INCLUDE-DEV-DEPS is true then this will also
+version of CRATE-NAME.  If INCLUDE-DEV-DEPS is true then this will also
 look up the development dependencs for the given crate."
 
   (define (semver-range-contains-string? range version)
@@ -242,63 +259,112 @@ look up the development dependencs for the given crate."
          (or version
              (crate-latest-version crate))))
 
-  ;; find the highest existing package that fulfills the semver <range>
+  ;; Find the highest existing package that fulfills the semver <range>.
+  ;; Packages previously marked as yanked take lower priority.
   (define (find-package-version name range)
     (let* ((semver-range (string->semver-range range))
-           (versions
+           (package-versions
             (sort
-             (filter (lambda (version)
-                       (semver-range-contains? semver-range version))
+             (filter (match-lambda ((semver yanked)
+                                    (and
+                                     (or allow-yanked? (not yanked))
+                                     (semver-range-contains? semver-range semver))))
                      (map (lambda (pkg)
-                            (string->semver (package-version pkg)))
+                            (let ((version (package-version pkg)))
+                              (list
+                                (string->semver version)
+                                (assoc-ref (package-properties pkg)
+                                           'crate-version-yanked?))))
                           (find-packages-by-name
                            (crate-name->package-name name))))
-             semver<?)))
-      (and (not (null-list? versions))
-           (semver->string (last versions)))))
-
-  ;; Find the highest version of a crate that fulfills the semver <range>
-  ;; and hasn't been yanked.
+             (match-lambda* (((semver1 yanked1) (semver2 yanked2))
+                             (or (and yanked1 (not yanked2))
+                                 (and (eq? yanked1 yanked2)
+                                      (semver<? semver1 semver2))))))))
+      (and (not (null-list? package-versions))
+           (match-let (((semver yanked) (last package-versions)))
+             (list (semver->string semver) yanked)))))
+
+  ;; Find the highest version of a crate that fulfills the semver <range>.
+  ;; If no matching non-yanked version has been found and allow-yanked? is #t,
+  ;; also consider yanked packages.
   (define (find-crate-version crate range)
     (let* ((semver-range (string->semver-range range))
            (versions
             (sort
              (filter (lambda (entry)
                        (and
-                         (not (crate-version-yanked? (second entry)))
+                         (or allow-yanked?
+                             (not (crate-version-yanked? (second entry))))
                          (semver-range-contains? semver-range (first entry))))
                      (map (lambda (ver)
                             (list (string->semver (crate-version-number ver))
                                   ver))
                           (crate-versions crate)))
-             (match-lambda* (((semver _) ...)
-                             (apply semver<? semver))))))
+             (match-lambda* (((semver ver) ...)
+                             (match-let (((yanked1 yanked2)
+                                          (map crate-version-yanked? ver)))
+                               (or (and yanked1 (not yanked2))
+                                   (and (eq? yanked1 yanked2)
+                                        (apply semver<? semver)))))))))
       (and (not (null-list? versions))
            (second (last versions)))))
 
-  (define (dependency-name+version dep)
+  ;; If no non-yanked existing package version was found, check the upstream
+  ;; versions.  If a non-yanked upsteam version exists, use it instead,
+  ;; otherwise use the existing package version, provided it exists.
+  (define (dependency-name+version+yanked dep)
     (let* ((name (crate-dependency-id dep))
-           (req (crate-dependency-requirement dep))
-           (existing-version (find-package-version name req)))
-      (if existing-version
-          (list name existing-version)
+                 (req (crate-dependency-requirement dep))
+                 (existing-version (find-package-version name req)))
+      (if (and existing-version (not (second existing-version)))
+          (cons name existing-version)
           (let* ((crate (lookup-crate* name))
                  (ver (find-crate-version crate req)))
-            (list name
-                  (crate-version-number ver))))))
+            (if existing-version
+                (if (and ver (not (crate-version-yanked? ver)))
+                    (if (semver=? (string->semver (first existing-version))
+                                  (string->semver (crate-version-number ver)))
+                        (begin
+                          (warning (G_ "~A: version ~a is no longer yanked~%")
+                                   name (first existing-version))
+                          (cons name existing-version))
+                        (list name
+                              (crate-version-number ver)
+                              (crate-version-yanked? ver)))
+                    (begin
+                      (warning (G_ "~A: using existing version ~a, which was yanked~%")
+                               name (first existing-version))
+                      (cons name existing-version)))
+                (begin
+                  (unless ver
+                    (leave (G_ "~A: no version found for requirement ~a~%") name req))
+                  (if (crate-version-yanked? ver)
+                      (warning (G_ "~A: imported version ~a was yanked~%")
+                               name (crate-version-number ver)))
+                  (list name
+                        (crate-version-number ver)
+                        (crate-version-yanked? ver))))))))
 
   (define version*
     (and crate
-         (find-crate-version crate version-number)))
+         (or (find-crate-version crate version-number)
+             (leave (G_ "~A: version ~a not found~%") crate-name version-number))))
 
   ;; sort and map the dependencies to a list containing
   ;; pairs of (name version)
   (define (sort-map-dependencies deps)
-    (sort (map dependency-name+version
+    (sort (map dependency-name+version+yanked
                deps)
-          (match-lambda* (((name _) ...)
+          (match-lambda* (((name _ _) ...)
                           (apply string-ci<? name)))))
 
+  (define (remove-yanked-info deps)
+    (map
+     (match-lambda ((name version yanked)
+                    (list name version)))
+     deps))
+
   (if (and crate version*)
       (let* ((dependencies (crate-version-dependencies version*))
              (dep-crates dev-dep-crates (partition normal-dependency? dependencies))
@@ -308,6 +374,7 @@ look up the development dependencs for the given crate."
                                            '())))
         (values
          (make-crate-sexp #:build? include-dev-deps?
+                          #:yanked? (crate-version-yanked? version*)
                           #:name crate-name
                           #:version (crate-version-number version*)
                           #:cargo-inputs cargo-inputs
@@ -324,19 +391,27 @@ look up the development dependencs for the given crate."
                           #:description (crate-description crate)
                           #:license (and=> (crate-version-license version*)
                                            string->license))
-         (append cargo-inputs cargo-development-inputs)))
+         (append
+          (remove-yanked-info cargo-inputs)
+          (remove-yanked-info cargo-development-inputs))))
       (values #f '())))
 
-(define* (crate-recursive-import crate-name #:key version)
-  (recursive-import crate-name
-                    #:repo->guix-package (lambda* params
-                      ;; download development dependencies only for the top level package
-                      (let ((include-dev-deps? (equal? (car params) crate-name))
-                            (crate->guix-package* (memoize crate->guix-package)))
-                        (apply crate->guix-package*
-                               (append params `(#:include-dev-deps? ,include-dev-deps?)))))
-                    #:version version
-                    #:guix-name crate-name->package-name))
+(define* (crate-recursive-import
+          crate-name #:key version recursive-dev-dependencies? allow-yanked?)
+  (recursive-import
+   crate-name
+   #:repo->guix-package
+   (let ((crate->guix-package* (memoize crate->guix-package)))
+     (lambda* params
+       ;; download development dependencies only for the top level package
+       (let ((include-dev-deps?
+              (or (equal? (car params) crate-name)
+                  recursive-dev-dependencies?)))
+         (apply crate->guix-package*
+                (append params `(#:include-dev-deps? ,include-dev-deps?
+                                 #:allow-yanked? ,allow-yanked?))))))
+   #:version version
+   #:guix-name crate-name->package-name))
 
 (define (guix-package->crate-name package)
   "Return the crate name of PACKAGE."
diff --git a/guix/read-print.scm b/guix/read-print.scm
index 690f5dacdd..6421b79737 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -46,6 +46,7 @@
             page-break
             page-break?
 
+            <comment>
             comment
             comment?
             comment->string
diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm
index 038faa87db..082a973aee 100644
--- a/guix/scripts/import/crate.scm
+++ b/guix/scripts/import/crate.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2023 David Elsing <david.elsing@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -47,6 +48,13 @@
 Import and convert the crates.io package for PACKAGE-NAME.\n"))
   (display (G_ "
   -r, --recursive        import packages recursively"))
+  (display (G_ "
+      --recursive-dev-dependencies
+                         include dev-dependencies recursively"))
+  (display (G_ "
+      --allow-yanked
+                         allow importing yanked crates if no alternative
+                         satisfying the version requirement exists"))
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -67,6 +75,12 @@ Import and convert the crates.io package for PACKAGE-NAME.\n"))
          (option '(#\r "recursive") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'recursive #t result)))
+         (option '("recursive-dev-dependencies") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'recursive-dev-dependencies #t result)))
+         (option '("allow-yanked") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'allow-yanked #t result)))
          %standard-import-options))
 
 
@@ -92,8 +106,14 @@ Import and convert the crates.io package for PACKAGE-NAME.\n"))
          (package-name->name+version spec))
 
        (match (if (assoc-ref opts 'recursive)
-                  (crate-recursive-import name #:version version)
-                  (crate->guix-package name #:version version #:include-dev-deps? #t))
+                  (crate-recursive-import
+                   name #:version version
+                   #:recursive-dev-dependencies?
+                   (assoc-ref opts 'recursive-dev-dependencies)
+                   #:allow-yanked? (assoc-ref opts 'allow-yanked))
+                  (crate->guix-package
+                   name #:version version #:include-dev-deps? #t
+                   #:allow-yanked? (assoc-ref opts 'allow-yanked)))
          ((or #f '())
           (leave (G_ "failed to download meta-data for package '~a'~%")
                  (if version
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 8071840de1..3e45c34895 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -8,6 +8,8 @@
 ;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; 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.
 ;;;
@@ -47,6 +49,7 @@
   #: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)
@@ -202,6 +205,16 @@ target the profile's @file{bin/env} file:
      (leave (G_ "~a: invalid symlink specification~%")
             arg))))
 
+(define (entry-point-argument-spec-option-parser opt name arg result)
+  "A SRFI-37 option parser for the --entry-point-argument option. The spec
+takes multiple occurrences. The entries are used in the exec form for the
+docker entry-point. The values are used as parameters in conjunction with the
+--entry-point option which is used as the first value in the exec form."
+  (let ((entry-point-argument (assoc-ref result 'entry-point-argument)))
+    (alist-cons 'entry-point-argument
+                (append entry-point-argument (list arg))
+                (alist-delete 'entry-point-argument result eq?))))
+
 (define (set-utf8-locale profile)
   "Configure the environment to use the \"en_US.utf8\" locale provided by the
 GLIBC-UT8-LOCALES package."
@@ -506,12 +519,15 @@ added to the pack."
                        localstatedir?
                        (symlinks '())
                        (archiver tar)
-                       (extra-options '()))
-  "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."
+                       (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.  If
+MAX-LAYERS is not false, the image will be splitted in up to MAX-LAYERS
+layers."
   (define database
     (and localstatedir?
          (file-append (store-database (list profile))
@@ -562,10 +578,28 @@ the image.  EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument."
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
-            (setenv "PATH" #+(file-append archiver "/bin"))
+            (define (form-entry-point prefix entry-point entry-point-argument)
+              ;; Construct entry-point parameter for build-docker-image.  The
+              ;; first entry is constructed by prefixing the entry-point with
+              ;; the supplied index, subsequent entries are taken from the
+              ;; --entry-point-argument options.
+              (and=> entry-point
+                     (lambda (entry-point)
+                       (cons* (string-append prefix "/" entry-point)
+                              entry-point-argument))))
+
+            (setenv "PATH"
+                    (string-join `(#+(file-append archiver "/bin")
+                                   #+@(if max-layers
+                                          (list (file-append gzip "/bin"))
+                                          '()))
+                                 ":"))
 
             (let-keywords '#$extra-options #f
-                          ((image-tag #f))
+                          ((image-tag #f)
+                           (entry-point-argument '())
+                           (max-layers #f))
+
               (build-docker-image #$output
                                   (map store-info-item
                                        (call-with-input-file "profile"
@@ -578,16 +612,16 @@ the image.  EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument."
                                   #:database #+database
                                   #:system (or #$target %host-type)
                                   #:environment environment
-                                  #:entry-point
-                                  #$(and entry-point
-                                         #~(list
-                                            (string-append #$profile "/"
-                                                           #$entry-point)))
+                                  #:entry-point (form-entry-point
+                                                 #$profile
+                                                 #$entry-point
+                                                 entry-point-argument)
                                   #:extra-files directives
                                   #: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))
@@ -1264,6 +1298,8 @@ last resort for relocation."
     (debug . 0)
     (verbosity . 1)
     (symlinks . ())
+    (entry-point-argument . ())
+    (max-layers . ,%docker-image-max-layers)
     (compressor . ,(first %compressors))))
 
 (define %formats
@@ -1299,7 +1335,13 @@ last resort for relocation."
                    rest))))
 
 (define %docker-format-options
-  (list (required-option 'image-tag)))
+  (list (required-option 'image-tag)
+        (option '(#\A "entry-point-argument") #t #f
+                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_ "
@@ -1308,7 +1350,15 @@ last resort for relocation."
 (define (show-docker-format-options/detailed)
   (display (G_ "
       --image-tag=NAME
-                         Use the given NAME for the Docker image repository"))
+                         Use the given NAME for the Docker image repository
+
+      -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
+
+      --max-layers=N
+                         Number of image layers"))
   (newline)
   (exit 0))
 
@@ -1619,7 +1669,11 @@ Create a bundle of PACKAGE.\n"))
                    (extra-options (match pack-format
                                     ('docker
                                      (list #:image-tag
-                                           (assoc-ref opts 'image-tag)))
+                                           (assoc-ref opts 'image-tag)
+                                           #: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/guix/scripts/size.scm b/guix/scripts/size.scm
index d26ed98388..8a8676a16f 100644
--- a/guix/scripts/size.scm
+++ b/guix/scripts/size.scm
@@ -317,7 +317,8 @@ Report the size of the PACKAGE or STORE-ITEM, with its dependencies.\n"))
           ;; Turn off grafts because (1) substitute servers do not serve grafted
           ;; packages, and (2) they do not make any difference on the
           ;; resulting size.
-          (parameterize ((%graft? #f))
+          (parameterize ((%graft? #f)
+                         (%current-system system))
             (with-store store
               (set-build-options store
                                  #:use-substitutes? #t
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)