Browse Source

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'.
Ludovic Courtès 2 years ago
committed by Ludovic Courtès
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
2 changed files with 43 additions and 13 deletions
  1. +30
  2. +13

+ 30
- 13
guix/docker.scm View File

@ -57,22 +57,36 @@
(created . ,time)
(container_config . #nil)))
(define (generate-tag path)
"Generate an image tag for the given PATH."
(match (string-split (basename path) #\-)
((hash name . rest) (string-append name ":" hash))))
(define (canonicalize-repository-name name)
"\"Repository\" names are restricted to roughtl [a-z0-9_.-].
Return a version of TAG that follows these rules."
(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)
(string-trim (string-downcase name) separators)))
(define* (manifest path id #:optional (tag "guix"))
"Generate a simple image manifest."
`#(((Config . "config.json")
(RepoTags . #(,(generate-tag path)))
(Layers . #(,(string-append id "/layer.tar"))))))
(let ((tag (canonicalize-repository-name tag)))
`#(((Config . "config.json")
(RepoTags . #(,(string-append tag ":latest")))
(Layers . #(,(string-append id "/layer.tar")))))))
;; According to the specifications this is required for backwards
;; 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-tag path) . ((latest . ,id)))))
`((,(canonicalize-repository-name tag) . ((latest . ,id)))))
;; See
(define* (config layer time arch #:key entry-point (environment '()))
@ -112,6 +126,7 @@
(define* (build-docker-image image paths prefix
(repository "guix")
(extra-files '())
(transformations '())
(system (utsname:machine (uname)))
@ -121,7 +136,9 @@
(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.
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.
@ -243,10 +260,10 @@ SRFI-19 time-utc object, as the creation time in metadata."
#:entry-point entry-point))))
(with-output-to-file "manifest.json"
(lambda ()
(scm->json (manifest prefix id))))
(scm->json (manifest prefix id repository))))
(with-output-to-file "repositories"
(lambda ()
(scm->json (repositories prefix id)))))
(scm->json (repositories prefix id repository)))))
(apply invoke "tar" "-cf" image "-C" directory

+ 13
- 0
guix/scripts/pack.scm View File

@ -516,6 +516,18 @@ the image."
`((directory "/tmp" ,(getuid) ,(getgid) #o1777)
,@(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)
(match names
((_) str)
((names ... _) (loop names))))))) ;drop one entry
(setenv "PATH" (string-append #$archiver "/bin"))
@ -524,6 +536,7 @@ the image."
(call-with-input-file "profile"
#:repository tag
#:database #+database
#:system (or #$target (utsname:machine (uname)))
#:environment environment