01/05: guix: pack: Add '--entry-point-argument' option.

[guix-commits]

wigust pushed a commit to branch master
in repository guix.

commit 7d5168a2af3ed922c6a46985124fb73402cc8844
Author: Graham James Addis <grahamjamesaddis@gmail.com>
AuthorDate: Wed Jul 12 09:17:13 2023 +0100

    guix: pack: Add '--entry-point-argument' option.
    
    * guix/scripts/pack.scm:
    (entry-point-argument-spec-option-parser): New procedure.
    (docker-image, %default-options, %docker-format-options,
    show-docker-format-options/detailed, %options, show-docker-format-options,
    guix-pack): Handle '--entry-point-argument' option.
    * doc/guix.texi: (Invoking guix pack): Document this
    
    Signed-off-by: Oleg Pykhalov <go.wigust@gmail.com>
    Change-Id: I1124feff6af39dcc63c85fd6cc7ad50f398489dc
---
 doc/guix.texi         | 14 +++++++++++++-
 guix/scripts/pack.scm | 50 +++++++++++++++++++++++++++++++++++++++++---------
 2 files changed, 54 insertions(+), 10 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index fc18deb85b..27ebed137d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -122,6 +122,7 @@ Copyright @copyright{} 2023 Felix Lechner@*
 Copyright @copyright{} 2023 Foundation Devices, Inc.@*
 Copyright @copyright{} 2023 Thomas Ieong@*
 Copyright @copyright{} 2023 Saku Laesvuori@*
+Copyright @copyright{} 2023 Graham James Addis@*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -7406,7 +7407,7 @@ execution engines listed above by setting the
 @env{GUIX_EXECUTION_ENGINE} environment variable accordingly.
 @end quotation
 
-@cindex entry point, for Docker images
+@cindex entry point, for Docker and Singularity images
 @item --entry-point=@var{command}
 Use @var{command} as the @dfn{entry point} of the resulting pack, if the pack
 format supports it---currently @code{docker} and @code{squashfs} (Singularity)
@@ -7429,6 +7430,17 @@ docker load -i pack.tar.gz
 docker run @var{image-id}
 @end example
 
+@cindex entry point arguments, for docker images
+@item --entry-point-argument=@var{command}
+@itemx -A @var{command}
+Use @var{command} as an argument to @dfn{entry point} of the resulting pack.
+This option is only valid in conjunction with @code{--entry-point} and can
+appear multiple times on the command line.
+
+@example
+guix pack -f docker --entry-point=bin/guile --entry-point-argument="--help" 
guile
+@end example
+
 @item --expression=@var{expr}
 @itemx -e @var{expr}
 Consider the package @var{expr} evaluates to.
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 8071840de1..4c0a602eb1 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer 
<maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Graham James Addis <graham@addis.org.uk>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -202,6 +203,16 @@ target the profile's @file{bin/env} file:
      (leave (G_ "~a: invalid symlink specification~%")
             arg))))
 
+(define (entry-point-argument-spec-option-parser opt name arg result)
+  "A SRFI-37 opion parser for the --entry-point-argument option. The spec
+takes multiple occurances. The entries are used in the exec form for the
+docker entry-point. The values are used as parameters in conjunction with
+the --entry-point option which is used as the first value in the exec form."
+  (let ((entry-point-argument (assoc-ref result 'entry-point-argument)))
+    (alist-cons 'entry-point-argument
+                (append entry-point-argument (list arg))
+                (alist-delete 'entry-point-argument result eq?))))
+
 (define (set-utf8-locale profile)
   "Configure the environment to use the \"en_US.utf8\" locale provided by the
 GLIBC-UT8-LOCALES package."
@@ -562,10 +573,22 @@ the image.  EXTRA-OPTIONS may contain the IMAGE-TAG 
keyword argument."
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
+            (define (form-entry-point prefix entry-point entry-point-argument)
+              ;; Construct entry-point parameter for build-docker-image.  The
+              ;; first entry is constructed by prefixing the entry-point with
+              ;; the supplied index subsequent entries are taken from the
+              ;; --entry-point-argument options.
+              (and=> entry-point
+                     (lambda (entry-point)
+                       (cons* (string-append prefix "/" entry-point)
+                             entry-point-argument))))
+
             (setenv "PATH" #+(file-append archiver "/bin"))
 
             (let-keywords '#$extra-options #f
-                          ((image-tag #f))
+                          ((image-tag #f)
+                           (entry-point-argument #f))
+
               (build-docker-image #$output
                                   (map store-info-item
                                        (call-with-input-file "profile"
@@ -578,11 +601,10 @@ the image.  EXTRA-OPTIONS may contain the IMAGE-TAG 
keyword argument."
                                   #:database #+database
                                   #:system (or #$target %host-type)
                                   #:environment environment
-                                  #:entry-point
-                                  #$(and entry-point
-                                         #~(list
-                                            (string-append #$profile "/"
-                                                           #$entry-point)))
+                                  #:entry-point (form-entry-point
+                                                 #$profile
+                                                 #$entry-point
+                                                 entry-point-argument)
                                   #:extra-files directives
                                   #:compressor
                                   #+(compressor-command compressor)
@@ -1264,6 +1286,7 @@ last resort for relocation."
     (debug . 0)
     (verbosity . 1)
     (symlinks . ())
+    (entry-point-argument . ())
     (compressor . ,(first %compressors))))
 
 (define %formats
@@ -1299,7 +1322,9 @@ last resort for relocation."
                    rest))))
 
 (define %docker-format-options
-  (list (required-option 'image-tag)))
+  (list (required-option 'image-tag)
+        (option '(#\A "entry-point-argument") #t #f
+                entry-point-argument-spec-option-parser)))
 
 (define (show-docker-format-options)
   (display (G_ "
@@ -1308,7 +1333,12 @@ last resort for relocation."
 (define (show-docker-format-options/detailed)
   (display (G_ "
       --image-tag=NAME
-                         Use the given NAME for the Docker image repository"))
+                         Use the given NAME for the Docker image repository
+
+      -A, --entry-point-argument=COMMAND/PARAMETER
+                         Value(s) to use for the Docker EntryPoint arguments.
+                         Multiple instances are accepted. This is only valid
+                         in conjunction with the --entry-point option"))
   (newline)
   (exit 0))
 
@@ -1619,7 +1649,9 @@ Create a bundle of PACKAGE.\n"))
                    (extra-options (match pack-format
                                     ('docker
                                      (list #:image-tag
-                                           (assoc-ref opts 'image-tag)))
+                                           (assoc-ref opts 'image-tag)
+                                           #:entry-point-argument
+                                           (assoc-ref opts 
'entry-point-argument)))
                                     ('deb
                                      (list #:control-file
                                            (process-file-arg opts 
'control-file)