pack: Add '--entry-point'.

* guix/scripts/pack.scm (self-contained-tarball): Add #:entry-point and
warn when it's true.
(squashfs-image): Add #:entry-point and honor it.
(docker-image): Add #:entry-point and honor it.
(%options, show-help): Add '--entry-point'.
(guix-pack): Honor '--entry-point' and pass #:entry-point to BUILD-IMAGE.
* gnu/tests/docker.scm (run-docker-test): Test 'docker run' with the
default entry point.
(build-tarball&run-docker-test): Pass #:entry-point to 'docker-image'.
* doc/guix.texi (Invoking guix pack): Document it.
* gnu/tests/singularity.scm (run-singularity-test)["singularity run"]:
New test.
(build-tarball&run-singularity-test): Pass #:entry-point to
'squashfs-image'.

4 files changed, 85 insertions, 7 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index d37d63066f..bd0f3e8fd5 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4866,6 +4866,29 @@ advantage to work without requiring special kernel support, but it incurs
 run-time overhead every time a system call is made.
 @end quotation
 
+@cindex entry point, for Docker 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)
+support it.  @var{command} must be relative to the profile contained in the
+pack.
+
+The entry point specifies the command that tools like @code{docker run} or
+@code{singularity run} automatically start by default.  For example, you can
+do:
+
+@example
+guix pack -f docker --entry-point=bin/guile guile
+@end example
+
+The resulting pack can easily be loaded and @code{docker run} with no extra
+arguments will spawn @code{bin/guile}:
+
+@example
+docker load -i pack.tar.gz
+docker run @var{image-id}
+@end example
+
 @item --expression=@var{expr}
 @itemx -e @var{expr}
 Consider the package @var{expr} evaluates to.
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 3cd3a27884..f2674cdbe8 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -101,7 +101,7 @@ inside %DOCKER-OS."
              marionette))
 
           (test-equal "Load docker image and run it"
-            "hello world"
+            '("hello world" "hi!")
             (marionette-eval
              `(begin
                 (define slurp
@@ -117,12 +117,16 @@ inside %DOCKER-OS."
                        (repository&tag (string-drop raw-line
                                                     (string-length
                                                      "Loaded image: ")))
-                       (response (slurp
-                                  ,(string-append #$docker-cli "/bin/docker")
-                                  "run" "--entrypoint" "bin/Guile"
-                                  repository&tag
-                                  "/aa.scm")))
-                  response))
+                       (response1 (slurp
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "run" "--entrypoint" "bin/Guile"
+                                   repository&tag
+                                   "/aa.scm"))
+                       (response2 (slurp          ;default entry point
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "run" repository&tag
+                                   "-c" "(display \"hi!\")")))
+                  (list response1 response2)))
              marionette))
 
           (test-end)
@@ -161,6 +165,7 @@ standard output device and then enters a new line.")
        (tarball (docker-image "docker-pack" profile
                               #:symlinks '(("/bin/Guile" -> "bin/guile")
                                            ("aa.scm" -> "a.scm"))
+                              #:entry-point "bin/guile"
                               #:localstatedir? #t)))
     (run-docker-test tarball)))
 
diff --git a/gnu/tests/singularity.scm b/gnu/tests/singularity.scm
index 55324ef9ea..668043a0bc 100644
--- a/gnu/tests/singularity.scm
+++ b/gnu/tests/singularity.scm
@@ -103,6 +103,14 @@
                    (cdr (waitpid pid)))))
              marionette))
 
+          (test-equal "singularity run"           ;test the entry point
+            42
+            (marionette-eval
+             `(status:exit-val
+               (system* #$(file-append singularity "/bin/singularity")
+                        "run" #$image "-c" "(exit 42)"))
+             marionette))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 
@@ -118,6 +126,7 @@
                                      #:hooks '()
                                      #:locales? #f))
        (tarball  (squashfs-image "singularity-pack" profile
+                                 #:entry-point "bin/guile"
                                  #:symlinks '(("/bin" -> "bin")))))
     (run-singularity-test tarball)))
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index c17b374330..5da23e038b 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -152,6 +152,7 @@ dependencies are registered."
                                  #:key target
                                  (profile-name "guix-profile")
                                  deduplicate?
+                                 entry-point
                                  (compressor (first %compressors))
                                  localstatedir?
                                  (symlinks '())
@@ -275,6 +276,10 @@ added to the pack."
                                           (_ #f))
                                         directives)))))))))
 
+  (when entry-point
+    (warning (G_ "entry point not supported in the '~a' format~%")
+             'tarball))
+
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
                     build
@@ -284,6 +289,7 @@ added to the pack."
                          #:key target
                          (profile-name "guix-profile")
                          (compressor (first %compressors))
+                         entry-point
                          localstatedir?
                          (symlinks '())
                          (archiver squashfs-tools-next))
@@ -315,6 +321,7 @@ added to the pack."
                        (ice-9 match))
 
           (define database #+database)
+          (define entry-point #$entry-point)
 
           (setenv "PATH" (string-append #$archiver "/bin"))
 
@@ -371,6 +378,28 @@ added to the pack."
                                                             target)))))))
                       '#$symlinks)
 
+                   ;; Create /.singularity.d/actions, and optionally the 'run'
+                   ;; script, used by 'singularity run'.
+                   "-p" "/.singularity.d d 555 0 0"
+                   "-p" "/.singularity.d/actions d 555 0 0"
+                   ,@(if entry-point
+                         `(;; This one if for Singularity 2.x.
+                           "-p"
+                           ,(string-append
+                             "/.singularity.d/actions/run s 777 0 0 "
+                             (relative-file-name "/.singularity.d/actions"
+                                                 (string-append #$profile "/"
+                                                                entry-point)))
+
+                           ;; This one is for Singularity 3.x.
+                           "-p"
+                           ,(string-append
+                             "/.singularity.d/runscript s 777 0 0 "
+                             (relative-file-name "/.singularity.d"
+                                                 (string-append #$profile "/"
+                                                                entry-point))))
+                         '())
+
                    ;; Create empty mount points.
                    "-p" "/proc d 555 0 0"
                    "-p" "/sys d 555 0 0"
@@ -392,6 +421,7 @@ added to the pack."
                        #:key target
                        (profile-name "guix-profile")
                        (compressor (first %compressors))
+                       entry-point
                        localstatedir?
                        (symlinks '())
                        (archiver tar))
@@ -425,6 +455,8 @@ the image."
                                 #$profile
                                 #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
+                                #:entry-point (string-append #$profile "/"
+                                                             #$entry-point)
                                 #:symlinks '#$symlinks
                                 #:compressor '#$(compressor-command compressor)
                                 #:creation-time (make-time time-utc 0 1))))))
@@ -689,6 +721,9 @@ please email '~a'~%")
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
                                (alist-delete 'system result eq?))))
+         (option '("entry-point") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'entry-point arg result)))
          (option '("target") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'target arg
@@ -766,6 +801,9 @@ Create a bundle of PACKAGE.\n"))
   (display (G_ "
   -m, --manifest=FILE    create a pack with the manifest from FILE"))
   (display (G_ "
+      --entry-point=PROGRAM
+                         use PROGRAM as the entry point of the pack"))
+  (display (G_ "
       --save-provenance  save provenance information"))
   (display (G_ "
       --localstatedir    include /var/guix in the resulting pack"))
@@ -889,6 +927,7 @@ Create a bundle of PACKAGE.\n"))
                                  (leave (G_ "~a: unknown pack format~%")
                                         pack-format))))
                  (localstatedir? (assoc-ref opts 'localstatedir?))
+                 (entry-point    (assoc-ref opts 'entry-point))
                  (profile-name   (assoc-ref opts 'profile-name))
                  (gc-root        (assoc-ref opts 'gc-root)))
             (when (null? (manifest-entries manifest))
@@ -919,6 +958,8 @@ Create a bundle of PACKAGE.\n"))
                                                      symlinks
                                                      #:localstatedir?
                                                      localstatedir?
+                                                     #:entry-point
+                                                     entry-point
                                                      #:profile-name
                                                      profile-name
                                                      #:archiver