diff options
Diffstat (limited to 'guix/docker.scm')
| -rw-r--r-- | guix/docker.scm | 48 |
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))) |