ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-17 20:27:36 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

pack: Improve naming of the packs store file names.

Browse source 
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 (define-with-source): New macro.
(manifest->friendly-name): Extract procedure from ...
(docker-image): ... here, now defined via the above macro.  Adjust REPOSITORY
argument value accordingly.
(guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
This commit is contained in:
Maxim Cournoyer 2021-06-17 15:09:46 -04:00
parent f72aa3834b
commit 6b0e55cde9
No known key found for this signature in database
GPG key ID: 1260E46482E63562
1 changed files with 31 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
guix/scripts/pack.scm
View file

@ -172,6 +172,28 @@ (define db-file
(computed-file "store-database" build
#:options `(#:references-graphs ,(zip labels items))))
(define-syntax-rule (define-with-source (variable args ...) body body* ...)
"Bind VARIABLE to a procedure accepting ARGS defined as BODY, also setting
its source property."
(begin
(define (variable args ...)
body body* ...)
(eval-when (load eval)
(set-procedure-property! variable 'source
'(define (variable args ...) body body* ...)))))
(define-with-source (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))))))
;;;
;;; Tarball format.
@ -540,7 +562,7 @@ (define database
(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 +580,8 @@ (define build
(srfi srfi-1) (srfi srfi-19)
(ice-9 match))
#$(procedure-source manifest->friendly-name)
(define environment
(map (match-lambda
((spec . value)
@ -581,19 +605,6 @@ (define directives
`((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 +612,8 @@ (define str (string-join names "-"))
(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 +1221,6 @@ (define with-provenance
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 +1254,10 @@ (define with-provenance
(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))))