| Message ID | 20210624044049.17906-4-maxim.cournoyer@gmail.com |
|---|---|
| State | Accepted |
| Headers | show |
| Series | [bug#49149,v2,1/7] pack: Extract builder code from self-contained-tarball. | expand |
| Context | Check | Description |
|---|---|---|
| cbaines/comparison | success | View comparision |
| cbaines/git branch | success | View Git branch |
| cbaines/applying patch | success | View Laminar job |
| cbaines/issue | success | View issue |
| cbaines/comparison | success | View comparision |
| cbaines/git branch | success | View Git branch |
| cbaines/applying patch | success | View Laminar job |
| cbaines/issue | success | View issue |
Hi, Maxim Cournoyer <maxim.cournoyer@gmail.com> writes: [...] > +(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) Some typo slipped here. It should have been body body* ..., as in the template. > + (eval-when (load eval) > + (set-procedure-property! variable 'source > + '(define (variable args ...) body body* ...))))) > + Thanks, Maxim
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > 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. [...] > - (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 I think this should not be factorized because the requirements are very Docker-dependent. Once factorized, it becomes easy to overlook this. Ludo’.
Hello, Ludovic Courtès <ludo@gnu.org> writes: > Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > >> 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. > > [...] > >> - (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 > > I think this should not be factorized because the requirements are very > Docker-dependent. Once factorized, it becomes easy to overlook this. Hmm, I'm not a docker format expert, but my quick reading about it turned no restrictions about what a docker image label should look like? So perhaps it is not specially Docker-dependent. If there's something truly Docker-dependent about it I'd suggest adding a #:docker-compatible? boolean option to the procedure. Maxim
Hi, Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > Ludovic Courtès <ludo@gnu.org> writes: > >> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: >> >>> 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. >> >> [...] >> >>> - (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 >> >> I think this should not be factorized because the requirements are very >> Docker-dependent. Once factorized, it becomes easy to overlook this. > > Hmm, I'm not a docker format expert, but my quick reading about it > turned no restrictions about what a docker image label should look like? > So perhaps it is not specially Docker-dependent. It’s a hack specifically written with Docker repository names in mind, and the 40-or-so character limit, for instance. > If there's something truly Docker-dependent about it I'd suggest adding > a #:docker-compatible? boolean option to the procedure. To me it’s a case where factorization isn’t beneficial. Even if there’s a similar procedure used in a different context, it’s still a different context with different constraints. My 2¢! Ludo’.
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 7ea97a4b7a..ad432f2b63 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -172,6 +172,28 @@ dependencies are registered." (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) + (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 @@ 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 +580,8 @@ the image." (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 @@ 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 +612,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 +1221,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 +1254,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))))