summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludovic.courtes@inria.fr>2019-09-13 17:32:16 +0200
committerLudovic Courtès <ludo@gnu.org>2019-09-16 10:25:31 +0200
commit0074844366381e3056d09492b8b437836c7adb61 (patch)
treee8c52ffdf1be258555b26b85bcec6cce954053e9
parent9bbaf2ae72ce8457702f50277fee908d2c43d13c (diff)
downloadpatches-0074844366381e3056d09492b8b437836c7adb61.tar
patches-0074844366381e3056d09492b8b437836c7adb61.tar.gz
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'.
-rw-r--r--guix/docker.scm43
-rw-r--r--guix/scripts/pack.scm13
2 files changed, 43 insertions, 13 deletions
diff --git a/guix/docker.scm b/guix/docker.scm
index 757bdeb458..97ac6d982b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -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)
+ 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 https://github.com/opencontainers/image-spec/blob/master/config.md
(define* (config layer time arch #:key entry-point (environment '()))
@@ -112,6 +126,7 @@
(define* (build-docker-image image paths prefix
#:key
+ (repository "guix")
(extra-files '())
(transformations '())
(system (utsname:machine (uname)))
@@ -121,7 +136,9 @@
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.
+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
`(,@%tar-determinism-options
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 055d6c95f5..2543f0c0b5 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -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)
+ str
+ (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"
read-reference-graph))
#$profile
+ #:repository tag
#:database #+database
#:system (or #$target (utsname:machine (uname)))
#:environment environment