From 0074844366381e3056d09492b8b437836c7adb61 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludovic.courtes@inria.fr>
Date: Fri, 13 Sep 2019 17:32:16 +0200
Subject: [PATCH] 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'.
---
 guix/docker.scm       | 43 ++++++++++++++++++++++++++++++-------------
 guix/scripts/pack.scm | 13 +++++++++++++
 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