From 52eb3db19cb9e5c294c86a8552a4baaa5b473672 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 29 Jan 2023 22:13:53 +0100
Subject: [PATCH] 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 @@ (define (relay-signal signal)
 
 (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 @@ (define (namespace-file pid namespace)
     (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 @@ (define (handle-argument arg result)
                                        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 @@ (define (namespaces pid)
   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*"