Merge remote-tracking branch 'origin/master' into staging

With resolved conflicts in:
	gnu/packages/bittorrent.scm
	gnu/packages/databases.scm
	gnu/packages/geo.scm
	gnu/packages/gnupg.scm
	gnu/packages/gstreamer.scm
	gnu/packages/gtk.scm
	gnu/packages/linux.scm
	gnu/packages/python-xyz.scm
	gnu/packages/xorg.scm
	guix/build/qt-utils.scm

1 files changed, 25 insertions, 23 deletions

diff --git a/guix/docker.scm b/guix/docker.scm
index 889aaeacb5..a6f73d423c 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; 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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +22,7 @@
 (define-module (guix docker)
   #:use-module (gcrypt hash)
   #:use-module (guix base16)
+  #:use-module (guix build pack)
   #:use-module ((guix build utils)
                 #:select (mkdir-p
                           delete-file-recursively
@@ -58,8 +60,13 @@
     (container_config . #nil)))
 
 (define (canonicalize-repository-name name)
-  "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
+  "\"Repository\" names are restricted to roughly [a-z0-9_.-].
 Return a version of TAG that follows these rules."
+  ;; Refer to https://docs.docker.com/docker-hub/repos/.
+  (define min-length 2)
+  (define padding-character #\a)
+  (define max-length 255)
+
   (define ascii-letters
     (string->char-set "abcdefghijklmnopqrstuvwxyz"))
 
@@ -69,11 +76,21 @@ Return a version of TAG that follows these rules."
   (define repo-char-set
     (char-set-union char-set:digit ascii-letters separators))
 
-  (string-map (lambda (chr)
-                (if (char-set-contains? repo-char-set chr)
-                    chr
-                    #\.))
-              (string-trim (string-downcase name) separators)))
+  (define normalized-name
+    (string-map (lambda (chr)
+                  (if (char-set-contains? repo-char-set chr)
+                      chr
+                      #\.))
+                (string-trim (string-downcase name) separators)))
+
+  (let ((l (string-length normalized-name)))
+    (match l
+      ((? (cut > <> max-length))
+       (string-take normalized-name max-length))
+      ((? (cut < <> min-length))
+       (string-append normalized-name
+                      (make-string (- min-length l) padding-character)))
+      (_ normalized-name))))
 
 (define* (manifest path id #:optional (tag "guix"))
   "Generate a simple image manifest."
@@ -110,18 +127,6 @@ Return a version of TAG that follows these rules."
     (rootfs . ((type . "layers")
                (diff_ids . #(,(layer-diff-id layer)))))))
 
-(define %tar-determinism-options
-  ;; GNU tar options to produce archives deterministically.
-  '("--sort=name" "--mtime=@1"
-    "--owner=root:0" "--group=root:0"
-
-    ;; When 'build-docker-image' is passed store items, the 'nlink' of the
-    ;; files therein leads tar to store hard links instead of actual copies.
-    ;; However, the 'nlink' count depends on deduplication in the store; it's
-    ;; an "implicit input" to the build process.  '--hard-dereference'
-    ;; eliminates it.
-    "--hard-dereference"))
-
 (define directive-file
   ;; Return the file or directory created by a 'evaluate-populate-directive'
   ;; directive.
@@ -238,7 +243,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
 
           (apply invoke "tar" "-cf" "../layer.tar"
                  `(,@transformation-options
-                   ,@%tar-determinism-options
+                   ,@(tar-base-options)
                    ,@paths
                    ,@(scandir "."
                               (lambda (file)
@@ -273,9 +278,6 @@ SRFI-19 time-utc object, as the creation time in metadata."
           (scm->json (repositories prefix id repository)))))
 
     (apply invoke "tar" "-cf" image "-C" directory
-           `(,@%tar-determinism-options
-             ,@(if compressor
-                   (list "-I" (string-join compressor))
-                   '())
+           `(,@(tar-base-options #:compressor compressor)
              "."))
     (delete-file-recursively directory)))