[bug#64171] [PATCH 0/1 v2] guix: pack: docker add --entry-point-argument options

[Graham James Addis <grahamjamesaddis@gmail.com>]

* guix/scripts/pack.scm: add support for parameters in entry-point
(entry-point-argument-spec-option-parser): add function to parse --entry-point-argument
(docker-image): Add function (form_entry_point) to handle --entry-point
vs --entry-point-argument merging
(docker-image): change call to (build-docker-image) to use (form-entry-point)
(%default-options): add dafault for --entry-point-argument option
(%docker-format-options): parser for --entry-point-argument
(show-docker-format-options): help for --docker-format-options
(show-docker-format-options/detailed): detailed help for --docker-format-options
(%options): add flag for --help-docker-format and add parser for --docker-format-options
(extra-options): add entry-point-argument option
(guix.texi): add documentation
---
 doc/guix.texi         |  14 +++++-
 guix/scripts/pack.scm | 107 ++++++++++++++++++++++++++++++++----------
 2 files changed, 95 insertions(+), 26 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 4e7faf8aea..10d220c7b9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -116,6 +116,7 @@
 Copyright @copyright{} 2023 Karl Hallsby@*
 Copyright @copyright{} 2023 Nathaniel Nicandro@*
 Copyright @copyright{} 2023 Tanguy Le Carrour@*
+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
@@ -7410,7 +7411,7 @@ Invoking guix pack
 @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)
@@ -7433,6 +7434,17 @@ Invoking guix pack
 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 0dc9979194..c620eb9dc0 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.
 ;;;
@@ -193,6 +194,16 @@ (define (symlink-spec-option-parser opt name arg result)
      (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."
@@ -626,6 +637,7 @@ (define* (docker-image name profile
                          (guix build utils)
                          (guix profiles) (guix search-paths)
                          (srfi srfi-1) (srfi srfi-19)
+                         (ice-9 optargs)
                          (ice-9 match))
 
             #$(procedure-source manifest->friendly-name)
@@ -653,31 +665,48 @@ (define* (docker-image name profile
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
-            (setenv "PATH" #+(file-append archiver "/bin"))
-
-            (build-docker-image #$output
-                                (map store-info-item
-                                     (call-with-input-file "profile"
-                                       read-reference-graph))
-                                #$profile
-                                #:repository (manifest->friendly-name
-                                              (profile-manifest #$profile))
-                                #:database #+database
-                                #:system (or #$target %host-type)
-                                #:environment environment
-                                #:entry-point
-                                #$(and entry-point
-                                       #~(list (string-append #$profile "/"
-                                                              #$entry-point)))
-                                #:extra-files directives
-                                #:compressor #+(compressor-command compressor)
-                                #:creation-time (make-time time-utc 0 1))))))
-
-  (gexp->derivation (string-append name ".tar"
-                                   (compressor-extension compressor))
-                    build
-                    #:target target
-                    #:references-graphs `(("profile" ,profile))))
+            (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
+              (cond
+	       (entry-point
+		(cons*
+		 (string-append prefix "/" entry-point)
+		 entry-point-argument)
+		)
+	       ('()))) ;empty list returned if no conditions are met
+
+            (let-keywords '#$extra-options #f ((entry-point-argument #f))
+
+              (setenv "PATH" #+(file-append archiver "/bin"))
+
+              (build-docker-image #$output
+                                  (map store-info-item
+                                       (call-with-input-file "profile"
+                                         read-reference-graph))
+                                  #$profile
+                                  #:repository (manifest->friendly-name
+                                                (profile-manifest #$profile))
+                                  #:database #+database
+                                  #:system (or #$target %host-type)
+                                  #:environment environment
+                                  #:entry-point (form-entry-point
+                                                 #$profile
+                                                 #$entry-point
+                                                 entry-point-argument)
+                                  #:extra-files directives
+                                  #:compressor #+(compressor-command compressor)
+                                  #:creation-time (make-time time-utc 0 1)))))))
+
+    (gexp->derivation (string-append name ".tar"
+                                     (compressor-extension compressor))
+                      build
+                      #:target target
+                      #:references-graphs `(("profile" ,profile))))
 
 \f
 ;;;
@@ -1346,6 +1375,7 @@ (define %default-options
     (debug . 0)
     (verbosity . 1)
     (symlinks . ())
+    (entry-point-argument . ())
     (compressor . ,(first %compressors))))
 
 (define %formats
@@ -1428,6 +1458,25 @@ (define (show-rpm-format-options/detailed)
   (newline)
   (exit 0))
 
+
+(define %docker-format-options
+  (list (option '(#\A "entry-point-argument") #t #f
+                entry-point-argument-spec-option-parser)))
+
+(define (show-docker-format-options)
+  (display (G_ "
+      --help-docker-format
+                         list options specific to the DOCKER format")))
+
+(define (show-docker-format-options/detailed)
+  (display (G_ "
+  -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))
+
 (define %options
   ;; Specifications of the command-line options.
   (cons* (option '(#\h "help") #f #f
@@ -1508,8 +1557,13 @@ (define %options
                  (lambda args
                    (show-rpm-format-options/detailed)))
 
+         (option '("help-docker-format") #f #f
+                 (lambda args
+                   (show-docker-format-options/detailed)))
+
          (append %deb-format-options
                  %rpm-format-options
+                 %docker-format-options
                  %transformation-options
                  %standard-build-options
                  %standard-cross-build-options
@@ -1528,6 +1582,7 @@ (define (show-help)
   (newline)
   (show-deb-format-options)
   (show-rpm-format-options)
+  (show-docker-format-options)
   (newline)
   (display (G_ "
   -f, --format=FORMAT    build a pack in the given FORMAT"))
@@ -1696,6 +1751,8 @@ (define-command (guix-pack . args)
                                            (process-file-arg opts 'preun-file)
                                            #:postun-file
                                            (process-file-arg opts 'postun-file)))
+                                    ('docker
+                                     (list #:entry-point-argument (assoc-ref opts 'entry-point-argument)))
                                     (_ '())))
                    (target      (assoc-ref opts 'target))
                    (bootstrap?  (assoc-ref opts 'bootstrap?))

base-commit: 2426e51688d479042ea115a634c6be2d8b9f3b99
-- 
2.39.2