01/09: container: Correctly report exit status.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 52eb3db19cb9e5c294c86a8552a4baaa5b473672
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Jan 29 22:13:53 2023 +0100

    container: Correctly report exit status.
    
    * gnu/build/linux-container.scm (container-excursion): Return the raw
    status value.
    * tests/containers.scm ("container-excursion, same namespaces"): Add
    'status:exit-val' call.
    * guix/scripts/container/exec.scm (guix-container-exec): Correctly
    handle the different cases.
---
 gnu/build/linux-container.scm   |  4 ++--
 guix/scripts/container/exec.scm | 10 +++++++++-
 tests/containers.scm            |  7 ++++---
 3 files changed, 15 insertions(+), 6 deletions(-)

diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 72e3a45422..d11c49c0d8 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -404,7 +404,7 @@ load path must be adjusted as needed."
 
 (define (container-excursion pid thunk)
   "Run THUNK as a child process within the namespaces of process PID and
-return the exit status."
+return the exit status, an integer as returned by 'waitpid'."
   (define (namespace-file pid namespace)
     (string-append "/proc/" (number->string pid) "/ns/" namespace))
 
@@ -436,7 +436,7 @@ return the exit status."
     (pid
      (match (waitpid pid)
        ((_ . status)
-        (status:exit-val status))))))
+        status)))))
 
 (define (container-excursion* pid thunk)
   "Like 'container-excursion', but return the return value of THUNK."
diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm
index 51b616b384..3e70b1d3c2 100644
--- a/guix/scripts/container/exec.scm
+++ b/guix/scripts/container/exec.scm
@@ -102,4 +102,12 @@ and the other containing arguments for the command to be 
executed."
                                        environment)
                              (apply execlp program program program-args)))))))
           (unless (zero? result)
-            (leave (G_ "exec failed with status ~d~%") result)))))))
+            (match (status:exit-val result)
+              (#f
+               (if (status:term-sig result)
+                   (leave (G_ "process terminated with signal ~a~%")
+                          (status:term-sig result))
+                   (leave (G_ "process stopped with signal ~a~%")
+                          (status:stop-sig result))))
+              (code
+               (leave (G_ "process exited with status ~d~%") code)))))))))
diff --git a/tests/containers.scm b/tests/containers.scm
index 608902c41a..1378b10f22 100644
--- a/tests/containers.scm
+++ b/tests/containers.scm
@@ -203,9 +203,10 @@
   42
   ;; The parent and child are in the same namespaces.  'container-excursion'
   ;; should notice that and avoid calling 'setns' since that would fail.
-  (container-excursion (getpid)
-    (lambda ()
-      (primitive-exit 42))))
+  (status:exit-val
+   (container-excursion (getpid)
+     (lambda ()
+       (primitive-exit 42)))))
 
 (skip-if-unsupported)
 (test-assert "container-excursion*"