pack: Provide a meaningful "repository name" for Docker.

Previously, images produced by 'guix pack -f docker' would always show
up as "profile" in the output of 'docker images'.  With this change,
'docker images' shows a name constructed from the packages found in the
image--e.g., "bash-coreutils-grep-sed".

* guix/docker.scm (canonicalize-repository-name): New procedure.
(generate-tag): Remove.
(manifest): Add optional 'tag' parameter and honor it.
(repositories): Likewise.
(build-docker-image): Add #:repository parameter and pass it to
'manifest' and 'repositories'.
* guix/scripts/pack.scm (docker-image)[build]: Compute 'tag' and pass it
as #:repository to 'build-docker-image'.
This commit is contained in:
Ludovic Courtès 2019-09-13 17:32:16 +02:00 committed by Ludovic Courtès
parent 9bbaf2ae72
commit 0074844366
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 43 additions and 13 deletions

View File

@ -57,22 +57,36 @@
(created . ,time) (created . ,time)
(container_config . #nil))) (container_config . #nil)))
(define (generate-tag path) (define (canonicalize-repository-name name)
"Generate an image tag for the given PATH." "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
(match (string-split (basename path) #\-) Return a version of TAG that follows these rules."
((hash name . rest) (string-append name ":" hash)))) (define ascii-letters
(string->char-set "abcdefghijklmnopqrstuvwxyz"))
(define (manifest path id) (define separators
(string->char-set "_-."))
(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* (manifest path id #:optional (tag "guix"))
"Generate a simple image manifest." "Generate a simple image manifest."
`#(((Config . "config.json") (let ((tag (canonicalize-repository-name tag)))
(RepoTags . #(,(generate-tag path))) `#(((Config . "config.json")
(Layers . #(,(string-append id "/layer.tar")))))) (RepoTags . #(,(string-append tag ":latest")))
(Layers . #(,(string-append id "/layer.tar")))))))
;; According to the specifications this is required for backwards ;; According to the specifications this is required for backwards
;; compatibility. It duplicates information provided by the manifest. ;; compatibility. It duplicates information provided by the manifest.
(define (repositories path id) (define* (repositories path id #:optional (tag "guix"))
"Generate a repositories file referencing PATH and the image ID." "Generate a repositories file referencing PATH and the image ID."
`((,(generate-tag path) . ((latest . ,id))))) `((,(canonicalize-repository-name tag) . ((latest . ,id)))))
;; See https://github.com/opencontainers/image-spec/blob/master/config.md ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
(define* (config layer time arch #:key entry-point (environment '())) (define* (config layer time arch #:key entry-point (environment '()))
@ -112,6 +126,7 @@
(define* (build-docker-image image paths prefix (define* (build-docker-image image paths prefix
#:key #:key
(repository "guix")
(extra-files '()) (extra-files '())
(transformations '()) (transformations '())
(system (utsname:machine (uname))) (system (utsname:machine (uname)))
@ -121,7 +136,9 @@
compressor compressor
(creation-time (current-time time-utc))) (creation-time (current-time time-utc)))
"Write to IMAGE a Docker image archive containing the given PATHS. PREFIX "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. 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 When DATABASE is true, copy it to /var/guix/db in the image and create
/var/guix/gcroots and friends. /var/guix/gcroots and friends.
@ -243,10 +260,10 @@ SRFI-19 time-utc object, as the creation time in metadata."
#:entry-point entry-point)))) #:entry-point entry-point))))
(with-output-to-file "manifest.json" (with-output-to-file "manifest.json"
(lambda () (lambda ()
(scm->json (manifest prefix id)))) (scm->json (manifest prefix id repository))))
(with-output-to-file "repositories" (with-output-to-file "repositories"
(lambda () (lambda ()
(scm->json (repositories prefix id))))) (scm->json (repositories prefix id repository)))))
(apply invoke "tar" "-cf" image "-C" directory (apply invoke "tar" "-cf" image "-C" directory
`(,@%tar-determinism-options `(,@%tar-determinism-options

View File

@ -516,6 +516,18 @@ the image."
`((directory "/tmp" ,(getuid) ,(getgid) #o1777) `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
,@(append-map symlink->directives '#$symlinks))) ,@(append-map symlink->directives '#$symlinks)))
(define tag
;; Compute a meaningful "repository" name, which will show up in
;; the output of "docker images".
(let ((manifest (profile-manifest #$profile)))
(let loop ((names (map manifest-entry-name
(manifest-entries manifest))))
(define str (string-join names "-"))
(if (< (string-length str) 40)
str
(match names
((_) str)
((names ... _) (loop names))))))) ;drop one entry
(setenv "PATH" (string-append #$archiver "/bin")) (setenv "PATH" (string-append #$archiver "/bin"))
@ -524,6 +536,7 @@ the image."
(call-with-input-file "profile" (call-with-input-file "profile"
read-reference-graph)) read-reference-graph))
#$profile #$profile
#:repository tag
#:database #+database #:database #+database
#:system (or #$target (utsname:machine (uname))) #:system (or #$target (utsname:machine (uname)))
#:environment environment #:environment environment