GNU bug report logs - #49149
[PATCH 0/7] Add deb format for guix pack.

Previous Next

Full log

View this message in rfc822 format

From: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
To: 49149 <at> debbugs.gnu.org
Cc: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Subject: [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names.
Date: Mon, 21 Jun 2021 02:12:02 -0400

Instead of just naming them by their pack type, add information from the
package(s) they contain to make it easier to differentiate them.

* guix/scripts/pack.scm (manifest->friendly-name): Extract procedure from ...
(docker-image): ... here.  Adjust REPOSITORY argument value accordingly.
(guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
---
 guix/scripts/pack.scm | 44 +++++++++++++++++++++++++------------------
 1 file changed, 26 insertions(+), 18 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 7ea97a4b7a..9d4bb9f497 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -172,6 +172,23 @@ dependencies are registered."
   (computed-file "store-database" build
                  #:options `(#:references-graphs ,(zip labels items))))
 
+;;; XXX: The following procedure has to *also* be used in the build side
+;;; G-Exp, because PROFILE is passed as a derivation in the tests.
+(define define-manifest->friendly-name
+  '(define (manifest->friendly-name manifest)
+     "Return a friendly name computed from the entries in MANIFEST, a
+<manifest> object."
+     (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
+
+(eval define-manifest->friendly-name (current-module))
+
 
 ;;;
 ;;; Tarball format.
@@ -540,7 +557,7 @@ the image."
          (file-append (store-database (list profile))
                       "/db/db.sqlite")))
 
-  (define defmod 'define-module)                  ;trick Geiser
+  (define defmod 'define-module)        ;trick Geiser
 
   (define build
     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
@@ -558,6 +575,8 @@ the image."
                          (srfi srfi-1) (srfi srfi-19)
                          (ice-9 match))
 
+            #$define-manifest->friendly-name
+
             (define environment
               (map (match-lambda
                      ((spec . value)
@@ -581,19 +600,6 @@ 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" #+(file-append archiver "/bin"))
 
             (build-docker-image #$output
@@ -601,7 +607,8 @@ the image."
                                      (call-with-input-file "profile"
                                        read-reference-graph))
                                 #$profile
-                                #:repository tag
+                                #:repository (manifest->friendly-name
+                                              (profile-manifest #$profile))
                                 #:database #+database
                                 #:system (or #$target %host-type)
                                 #:environment environment
@@ -1209,8 +1216,6 @@ Create a bundle of PACKAGE.\n"))
                                        manifest)
                                       manifest)))
                    (pack-format (assoc-ref opts 'format))
-                   (name        (string-append (symbol->string pack-format)
-                                               "-pack"))
                    (target      (assoc-ref opts 'target))
                    (bootstrap?  (assoc-ref opts 'bootstrap?))
                    (compressor  (if bootstrap?
@@ -1244,7 +1249,10 @@ Create a bundle of PACKAGE.\n"))
                                     (hooks (if bootstrap?
                                                '()
                                                %default-profile-hooks))
-                                    (locales? (not bootstrap?)))))
+                                    (locales? (not bootstrap?))))
+                   (name (string-append (manifest->friendly-name manifest)
+                                        "-" (symbol->string pack-format)
+                                        "-pack")))
               (define (lookup-package package)
                 (manifest-lookup manifest (manifest-pattern (name package))))
 
-- 
2.32.0

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.