[PATCH 00/12] Add "least authority" program wrapper

DoneSubmitted by Ludovic Courtès.
Details
3 participants
  • Thiago Jung Bauermann
  • Ludovic Courtès
  • Maxime Devos
Owner
unassigned
Severity
normal
L
L
Ludovic Courtès wrote on 17 Apr 23:01 +0200
(address . guix-patches@gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210107.27263-1-ludo@gnu.org
Hello Guix!

So we have this fancy ‘make-forkexec-constructor/container’ thing
to spawn Shepherd services in a container:


It’s nice, but it doesn’t compose. What if you want an inetd-style
service *and* have it run in a container? We certainly don’t want to
end up defining ‘make-inetd-constructor/container’ and so on.

Instead, the new (guix least-authority) module provides a way to
create “least-authority wrappers” for a given program: the wrapper
forks[*] a process that lives in separate namespaces, with
‘call-with-container’, sets up bind mounts and everything in the child,
and executes the program in that environment. ([*] I considered
using unshare(2) instead of forking but that doesn’t quite work,
notably because the process itself would remain in the same PID
namespace as its parent.)

Subsequent patches change most, but not all, users of
‘make-forkexec-constructor/container’ to ‘least-authority-wrapper’.

One situation where ‘make-forkexec-constructor/container’ cannot be
replaced yet is when we rely on #:pid-file, as is the case for Tor
(‘make-forkexec-constructor/container’ goes to great lengths to read
PID files in the container and be happy with a PID that is only
valid within that namespace.) The remaining users are Jami and
Pagekite; that is left as an exercise to the reader. :-)

I have plans to use ‘least-authority-wrapper’ in other contexts, in
particular as the basis of a new package transformation option.

Thoughts?

Ludo’.

Ludovic Courtès (12):
gexp: Add 'references-file'.
file-systems: Avoid load-time warnings when attempting to load (guix
store).
linux-container: 'call-with-container' relays SIGTERM and SIGINT.
Add (guix least-authority).
services: dicod: Rewrite using 'least-authority-wrapper'.
services: dicod: Use 'make-inetd-constructor'.
services: bitlbee: Use 'make-inetd-constructor'.
services: ipfs: Adjust for Shepherd 0.9.
services: ipfs: Use 'least-authority-wrapper'.
services: wesnothd: Grant write access to /var/run/wesnothd.
services: wesnothd: Use 'least-authority-wrapper'.
services: quassel: Use 'least-authority-wrapper'.

Makefile.am | 1 +
gnu/build/linux-container.scm | 15 ++--
gnu/build/shepherd.scm | 3 +-
gnu/services/base.scm | 22 ------
gnu/services/dict.scm | 61 ++++++++++------
gnu/services/games.scm | 33 +++++++--
gnu/services/messaging.scm | 105 +++++++++++++++++----------
gnu/services/networking.scm | 118 +++++++++++++++---------------
gnu/system/file-systems.scm | 5 +-
gnu/tests/messaging.scm | 21 +-----
guix/gexp.scm | 43 +++++++++++
guix/least-authority.scm | 131 ++++++++++++++++++++++++++++++++++
tests/gexp.scm | 18 +++++
13 files changed, 403 insertions(+), 173 deletions(-)
create mode 100644 guix/least-authority.scm


base-commit: 950f3e4f98add14f645dc4c9f8c512cac7b8a779
--
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 02/12] file-systems: Avoid load-time warnings when attempting to load (guix store).
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-2-ludo@gnu.org
This makes sure warnings like "incompatible bytecode version" don't go
through when looking for (guix store).

* gnu/system/file-systems.scm (%store-prefix): Parameterize
'current-warning-port' around 'resolve-module' call.
---
gnu/system/file-systems.scm | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)

Toggle diff (23 lines)
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 437f8da898..f8f4276283 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Google LLC
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -272,7 +272,8 @@ (define (%store-prefix)
   ;; Note: If we have (guix store database) in the search path and we do *not*
   ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
   ;; with one sub-module.
-  (cond ((and=> (resolve-module '(guix store) #:ensure #f)
+  (cond ((and=> (parameterize ((current-warning-port (%make-void-port "w0")))
+                  (resolve-module '(guix store) #:ensure #f))
                 (lambda (store)
                   (module-variable store '%store-prefix)))
          =>
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 01/12] gexp: Add 'references-file'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-1-ludo@gnu.org
* gnu/services/base.scm (references-file): Remove.
* guix/gexp.scm (references-file): New procedure.
* tests/gexp.scm ("references-file"): New test.
---
gnu/services/base.scm | 22 ----------------------
guix/gexp.scm | 43 +++++++++++++++++++++++++++++++++++++++++++
tests/gexp.scm | 18 ++++++++++++++++++
3 files changed, 61 insertions(+), 22 deletions(-)

Toggle diff (132 lines)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 5d7c69a9cd..182badd97f 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -219,8 +219,6 @@ (define-module (gnu services base)
             pam-limits-service-type
             pam-limits-service
 
-            references-file
-
             %base-services))
 
 ;;; Commentary:
@@ -1768,26 +1766,6 @@ (define (guix-activation config)
               (substitute-key-authorization authorized-keys guix)
               #~#f))))
 
-(define* (references-file item #:optional (name "references"))
-  "Return a file that contains the list of references of ITEM."
-  (if (struct? item)                              ;lowerable object
-      (computed-file name
-                     (with-extensions (list guile-gcrypt) ;for store-copy
-                       (with-imported-modules (source-module-closure
-                                               '((guix build store-copy)))
-                         #~(begin
-                             (use-modules (guix build store-copy))
-
-                             (call-with-output-file #$output
-                               (lambda (port)
-                                 (write (map store-info-item
-                                             (call-with-input-file "graph"
-                                               read-reference-graph))
-                                        port))))))
-                     #:options `(#:local-build? #f
-                                 #:references-graphs (("graph" ,item))))
-      (plain-file name "()")))
-
 (define guix-service-type
   (service-type
    (name 'guix)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 9fdb7a30be..9ef7622062 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -118,6 +118,7 @@ (define-module (guix gexp)
             mixed-text-file
             file-union
             directory-union
+            references-file
 
             imported-files
             imported-modules
@@ -2173,6 +2174,48 @@ (define log-port
                                            #:resolve-collision
                                            (ungexp resolve-collision)))))))))
 
+(define* (references-file item #:optional (name "references")
+                          #:key guile)
+  "Return a file that contains the list of direct and indirect references (the
+closure) of ITEM."
+  (if (struct? item)                              ;lowerable object
+      (computed-file name
+                     (gexp (begin
+                             (use-modules (ice-9 rdelim)
+                                          (ice-9 match))
+
+                             (define (drop-lines port n)
+                               ;; Drop N lines read from PORT.
+                               (let loop ((n n))
+                                 (unless (zero? n)
+                                   (read-line port)
+                                   (loop (- n 1)))))
+
+                             (define (read-graph port)
+                               ;; Return the list of references read from
+                               ;; PORT.  This is a stripped-down version of
+                               ;; 'read-reference-graph'.
+                               (let loop ((items '()))
+                                 (match (read-line port)
+                                   ((? eof-object?)
+                                    items)
+                                   ((? string? item)
+                                    (let ((deriver (read-line port))
+                                          (count
+                                           (string->number (read-line port))))
+                                      (drop-lines port count)
+                                      (loop (cons item items)))))))
+
+                             (call-with-output-file (ungexp output)
+                               (lambda (port)
+                                 (write (call-with-input-file "graph"
+                                          read-graph)
+                                        port)))))
+                     #:guile guile
+                     #:options `(#:local-build? #t
+                                 #:references-graphs (("graph" ,item))))
+      (plain-file name "()")))
+
 
 ;;;
 ;;; Syntactic sugar.
diff --git a/tests/gexp.scm b/tests/gexp.scm
index c80ca13fab..35bd99e6d4 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1606,6 +1606,24 @@ (define (contents=? file str)
                    (not (member (derivation-file-name native) refs))
                    (member (derivation-file-name cross) refs))))))
 
+(test-assertm "references-file"
+  (let* ((exp      #~(symlink #$%bootstrap-guile #$output))
+         (computed (computed-file "computed" exp
+                                  #:guile %bootstrap-guile))
+         (refs     (references-file computed "refs"
+                                    #:guile %bootstrap-guile)))
+    (mlet* %store-monad ((drv0 (lower-object %bootstrap-guile))
+                         (drv1 (lower-object computed))
+                         (drv2 (lower-object refs)))
+      (mbegin %store-monad
+        (built-derivations (list drv2))
+        (mlet %store-monad ((refs ((store-lift requisites)
+                                   (list (derivation->output-path drv1)))))
+          (return (lset= string=?
+                         (call-with-input-file (derivation->output-path drv2)
+                           read)
+                         refs)))))))
+
 (test-assert "lower-object & gexp-input-error?"
   (guard (c ((gexp-input-error? c)
              (gexp-error-invalid-input c)))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 03/12] linux-container: 'call-with-container' relays SIGTERM and SIGINT.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-3-ludo@gnu.org
* gnu/build/linux-container.scm (call-with-container): Add #:relayed-signals
and honor it.
---
gnu/build/linux-container.scm | 15 ++++++++++-----
1 file changed, 10 insertions(+), 5 deletions(-)

Toggle diff (42 lines)
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index bdeca2cdb9..c19029aa65 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -303,6 +303,7 @@ (define (call-with-temporary-directory proc)
 
 (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
                               (host-uids 1) (guest-uid 0) (guest-gid 0)
+                              (relayed-signals (list SIGINT SIGTERM))
                               (process-spawned-hook (const #t)))
   "Run THUNK in a new container process and return its exit status; call
 PROCESS-SPAWNED-HOOK with the PID of the new process that has been spawned.
@@ -320,6 +321,9 @@ (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
 GUEST-UID and GUEST-GID specify the first UID (respectively GID) that host
 UIDs (respectively GIDs) map to in the namespace.
 
+RELAYED-SIGNALS is the list of signals that are \"relayed\" to the container
+process when caught by its parent.
+
 Note that if THUNK needs to load any additional Guile modules, the relevant
 module files must be present in one of the mappings in MOUNTS and the Guile
 load path must be adjusted as needed."
@@ -328,11 +332,12 @@ (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
      (let ((pid (run-container root mounts namespaces host-uids thunk
                                #:guest-uid guest-uid
                                #:guest-gid guest-gid)))
-       ;; Catch SIGINT and kill the container process.
-       (sigaction SIGINT
-         (lambda (signum)
-           (false-if-exception
-            (kill pid SIGKILL))))
+       (define (relay-signal signal)
+         (false-if-exception (kill pid signal)))
+
+       (for-each (lambda (signal)
+                   (sigaction signal relay-signal))
+                 relayed-signals)
 
        (process-spawned-hook pid)
        (match (waitpid pid)
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 04/12] Add (guix least-authority).
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-4-ludo@gnu.org
* guix/least-authority.scm: New file.
* Makefile.am (MODULES): Add it.
* gnu/build/shepherd.scm (default-mounts): Make public.
---
Makefile.am | 1 +
gnu/build/shepherd.scm | 3 +-
guix/least-authority.scm | 131 +++++++++++++++++++++++++++++++++++++++
3 files changed, 134 insertions(+), 1 deletion(-)
create mode 100644 guix/least-authority.scm

Toggle diff (165 lines)
diff --git a/Makefile.am b/Makefile.am
index fecce7c6f7..d0d58da4e3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -130,6 +130,7 @@ MODULES =					\
   guix/cache.scm				\
   guix/cve.scm					\
   guix/workers.scm				\
+  guix/least-authority.scm			\
   guix/ipfs.scm					\
   guix/build-system.scm				\
   guix/build-system/android-ndk.scm		\
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index d52e53eb78..f4caefce3c 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -31,7 +31,8 @@ (define-module (gnu build shepherd)
                                  exec-command
                                  %precious-signals)
   #:autoload (shepherd system) (unblock-signals)
-  #:export (make-forkexec-constructor/container
+  #:export (default-mounts
+            make-forkexec-constructor/container
             fork+exec-command/container))
 
 ;;; Commentary:
diff --git a/guix/least-authority.scm b/guix/least-authority.scm
new file mode 100644
index 0000000000..806c47508f
--- /dev/null
+++ b/guix/least-authority.scm
@@ -0,0 +1,131 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix least-authority)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module ((guix store) #:select (%store-prefix))
+  #:autoload   (gnu build linux-container) (%namespaces)
+  #:autoload   (gnu system file-systems) (file-system-mapping
+                                          file-system-mapping-source
+                                          spec->file-system
+                                          file-system->spec
+                                          file-system-mapping->bind-mount)
+  #:export (least-authority-wrapper))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to execute programs with the least authority
+;;; necessary, using Linux namespaces.
+;;;
+;;; Code:
+
+(define %precious-variables
+  ;; Environment variables preserved by the wrapper by default.
+  '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER"))
+
+(define* (least-authority-wrapper program
+                                  #:key (name "pola-wrapper")
+                                  (guest-uid 1000)
+                                  (guest-gid 1000)
+                                  (mappings '())
+                                  (namespaces %namespaces)
+                                  (directory "/")
+                                  (preserved-environment-variables
+                                   %precious-variables))
+  "Return a wrapper of PROGRAM that executes it with the least authority.
+
+PROGRAM is executed in separate namespaces according to NAMESPACES, a list of
+symbols; it turns with GUEST-UID and GUEST-GID.  MAPPINGS is a list of
+<file-system-mapping> records indicating directories mirrored inside the
+execution environment of PROGRAM.  DIRECTORY is the working directory of the
+wrapped process.  Each environment listed in PRESERVED-ENVIRONMENT-VARIABLES
+is preserved; other environment variables are erased."
+  (define code
+    (with-imported-modules (source-module-closure
+                            '((gnu system file-systems)
+                              (gnu build shepherd)
+                              (gnu build linux-container)))
+      #~(begin
+          (use-modules (gnu system file-systems)
+                       (gnu build linux-container)
+                       ((gnu build shepherd) #:select (default-mounts))
+                       (srfi srfi-1))
+
+          (define variables
+            (filter-map (lambda (variable)
+                          (let ((value (getenv variable)))
+                            (and value
+                                 (string-append variable "=" value))))
+                        '#$preserved-environment-variables))
+
+          (define (read-file file)
+            (call-with-input-file file read))
+
+          (define references
+            (delete-duplicates
+             (append-map read-file
+                         '#$(map references-file
+                                 (cons program
+                                       (map file-system-mapping-source
+                                            mappings))))))
+
+          (define (store? file-system)
+            (string=? (file-system-mount-point file-system)
+                      #$(%store-prefix)))
+
+          (define mounts
+            (append (map (lambda (item)
+                           (file-system-mapping->bind-mount
+                            (file-system-mapping (source item)
+                                                 (target item))))
+                         references)
+                    (remove store?
+                            (default-mounts
+                              #:namespaces '#$namespaces))
+                    (map spec->file-system
+                         '#$(map (compose file-system->spec
+                                          file-system-mapping->bind-mount)
+                                 mappings))))
+
+          (define (reify-exit-status status)
+            (cond ((status:exit-val status) => exit)
+                  ((or (status:term-sig status)
+                       (status:stop-sig status))
+                   => (lambda (signal)
+                        (format (current-error-port)
+                                "~a terminated with signal ~a~%"
+                                #$program signal)
+                        (exit 126)))))
+
+          ;; Note: 'call-with-container' creates a sub-process that this one
+          ;; waits for.  This might seem suboptimal but unshare(2) isn't
+          ;; really applicable: the process would still run in the same PID
+          ;; namespace.
+
+          (reify-exit-status
+           (call-with-container mounts
+             (lambda ()
+               (chdir #$directory)
+               (environ variables)
+               (apply execl #$program #$program (cdr (command-line))))
+             #:guest-uid #$guest-uid
+             #:guest-gid #$guest-gid
+             #:namespaces '#$namespaces)))))
+
+  (program-file name code))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 06/12] services: dicod: Use 'make-inetd-constructor'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-6-ludo@gnu.org
* gnu/services/dict.scm (dicod-shepherd-service): Use
'make-inetd-constructor' in the 'start' method when available.
---
gnu/services/dict.scm | 18 ++++++++++++++----
1 file changed, 14 insertions(+), 4 deletions(-)

Toggle diff (38 lines)
diff --git a/gnu/services/dict.scm b/gnu/services/dict.scm
index 62b21f8d53..109917c05c 100644
--- a/gnu/services/dict.scm
+++ b/gnu/services/dict.scm
@@ -146,6 +146,7 @@ (define %dicod-activation
 
 (define (dicod-shepherd-service config)
   (let* ((dicod.conf (dicod-configuration-file config))
+         (interfaces (dicod-configuration-interfaces config))
          (dicod      (least-authority-wrapper
                       (file-append (dicod-configuration-dico config)
                                    "/bin/dicod")
@@ -165,10 +166,19 @@ (define (dicod-shepherd-service config)
            (provision '(dicod))
            (requirement '(user-processes))
            (documentation "Run the dicod daemon.")
-           (start #~(make-forkexec-constructor
-                     (list #$dicod "--foreground"
-                           (string-append "--config=" #$dicod.conf))
-                     #:user "dicod" #:group "dicod"))
+           (start #~(if (and (defined? 'make-inetd-constructor)
+                             #$(= 1 (length interfaces))) ;XXX
+                        (make-inetd-constructor
+                         (list #$dicod "--inetd" "--foreground"
+                               (string-append "--config=" #$dicod.conf))
+                         (addrinfo:addr
+                          (car (getaddrinfo #$(first interfaces) "dict")))
+                         #:user "dicod" #:group "dicod"
+                         #:service-name-stem "dicod")
+                        (make-forkexec-constructor
+                         (list #$dicod "--foreground"
+                               (string-append "--config=" #$dicod.conf))
+                         #:user "dicod" #:group "dicod")))
            (stop #~(make-kill-destructor))))))
 
 (define dicod-service-type
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 05/12] services: dicod: Rewrite using 'least-authority-wrapper'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-5-ludo@gnu.org
* gnu/services/dict.scm (dicod-shepherd-service): Rewrite using
'least-authority-wrapper' plus 'make-forkexec-constructor' instead of
'make-forkexec-constructor/container'.
---
gnu/services/dict.scm | 51 ++++++++++++++++++++++++-------------------
1 file changed, 29 insertions(+), 22 deletions(-)

Toggle diff (83 lines)
diff --git a/gnu/services/dict.scm b/gnu/services/dict.scm
index a97ad8f608..62b21f8d53 100644
--- a/gnu/services/dict.scm
+++ b/gnu/services/dict.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Sou Bunnbu <iyzsong@gmail.com>
-;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -22,12 +22,15 @@ (define-module (gnu services dict)
   #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix least-authority)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system shadow)
   #:use-module ((gnu packages admin) #:select (shadow))
   #:use-module (gnu packages dico)
   #:use-module (gnu packages dictionaries)
+  #:autoload   (gnu build linux-container) (%namespaces)
+  #:autoload   (gnu system file-systems) (file-system-mapping)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -142,27 +145,31 @@ (define %dicod-activation
         (chown rundir (passwd:uid user) (passwd:gid user)))))
 
 (define (dicod-shepherd-service config)
-  (let ((dicod      (file-append (dicod-configuration-dico config)
-                                 "/bin/dicod"))
-        (dicod.conf (dicod-configuration-file config)))
-    (with-imported-modules (source-module-closure
-                            '((gnu build shepherd)
-                              (gnu system file-systems)))
-      (list (shepherd-service
-             (provision '(dicod))
-             (requirement '(user-processes))
-             (documentation "Run the dicod daemon.")
-             (modules '((gnu build shepherd)
-                        (gnu system file-systems)))
-             (start #~(make-forkexec-constructor/container
-                       (list #$dicod "--foreground"
-                             (string-append "--config=" #$dicod.conf))
-                       #:user "dicod" #:group "dicod"
-                       #:mappings (list (file-system-mapping
-                                         (source "/var/run/dicod")
-                                         (target source)
-                                         (writable? #t)))))
-             (stop #~(make-kill-destructor)))))))
+  (let* ((dicod.conf (dicod-configuration-file config))
+         (dicod      (least-authority-wrapper
+                      (file-append (dicod-configuration-dico config)
+                                   "/bin/dicod")
+                      #:name "dicod"
+                      #:mappings (list (file-system-mapping
+                                        (source "/var/run/dicod")
+                                        (target source)
+                                        (writable? #t))
+                                       (file-system-mapping
+                                        (source "/dev/log")
+                                        (target source))
+                                       (file-system-mapping
+                                        (source dicod.conf)
+                                        (target source)))
+                      #:namespaces (delq 'net %namespaces))))
+    (list (shepherd-service
+           (provision '(dicod))
+           (requirement '(user-processes))
+           (documentation "Run the dicod daemon.")
+           (start #~(make-forkexec-constructor
+                     (list #$dicod "--foreground"
+                           (string-append "--config=" #$dicod.conf))
+                     #:user "dicod" #:group "dicod"))
+           (stop #~(make-kill-destructor))))))
 
 (define dicod-service-type
   (service-type
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 07/12] services: bitlbee: Use 'make-inetd-constructor'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-7-ludo@gnu.org
* gnu/services/messaging.scm (bitlbee-shepherd-service): Add call to
'least-authority-wrapper'. In 'start' method, use
'make-inetd-constructor' when available.
* gnu/tests/messaging.scm (run-bitlbee-test)["valid PID"]: Remove test.
---
gnu/services/messaging.scm | 63 ++++++++++++++++++++++++++++----------
gnu/tests/messaging.scm | 21 +------------
2 files changed, 48 insertions(+), 36 deletions(-)

Toggle diff (140 lines)
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
index 4bceb1d37a..7fdd8cf285 100644
--- a/gnu/services/messaging.scm
+++ b/gnu/services/messaging.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017-2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Pierre-Antoine Rouby <contact@parouby.fr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -28,11 +28,14 @@ (define-module (gnu services messaging)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services configuration)
   #:use-module (gnu system shadow)
+  #:autoload   (gnu build linux-container) (%namespaces)
+  #:use-module ((gnu system file-systems) #:select (file-system-mapping))
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix deprecation)
+  #:use-module (guix least-authority)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
@@ -821,7 +824,18 @@ (define bitlbee-shepherd-service
   DaemonInterface = " interface "
   DaemonPort = " (number->string port) "
   PluginDir = " plugins "/lib/bitlbee
-" extra-settings)))
+" extra-settings))
+            (bitlbee* (least-authority-wrapper
+                       (file-append bitlbee "/sbin/bitlbee")
+                       #:name "bitlbee"
+                       #:mappings (list (file-system-mapping
+                                         (source "/var/lib/bitlbee")
+                                         (target source)
+                                         (writable? #t))
+                                        (file-system-mapping
+                                         (source conf)
+                                         (target conf)))
+                       #:namespaces (delq 'net %namespaces))))
 
        (with-imported-modules (source-module-closure
                                '((gnu build shepherd)
@@ -836,20 +850,37 @@ (define bitlbee-shepherd-service
 
                 (modules '((gnu build shepherd)
                            (gnu system file-systems)))
-                (start #~(make-forkexec-constructor/container
-                          (list #$(file-append bitlbee "/sbin/bitlbee")
-                                "-n" "-F" "-u" "bitlbee" "-c" #$conf)
-
-                          ;; Allow 'bitlbee-purple' to use libpurple plugins.
-                          #:environment-variables
-                          (list (string-append "PURPLE_PLUGIN_PATH="
-                                               #$plugins "/lib/purple-2"))
-
-                          #:pid-file "/var/run/bitlbee.pid"
-                          #:mappings (list (file-system-mapping
-                                            (source "/var/lib/bitlbee")
-                                            (target source)
-                                            (writable? #t)))))
+                (start #~(if (defined? 'make-inetd-constructor)
+
+                             (make-inetd-constructor
+                              (list #$bitlbee* "-I"
+                                    "-u" "bitlbee" "-c" #$conf)
+                              (addrinfo:addr
+                               (car (getaddrinfo #$interface
+                                                 #$(number->string port)
+                                                 (logior AI_NUMERICHOST
+                                                         AI_NUMERICSERV))))
+                              #:service-name-stem "bitlbee"
+
+                              ;; Allow 'bitlbee-purple' to use libpurple plugins.
+                              #:environment-variables
+                              (list (string-append "PURPLE_PLUGIN_PATH="
+                                                   #$plugins "/lib/purple-2")))
+
+                             (make-forkexec-constructor/container
+                              (list #$(file-append bitlbee "/sbin/bitlbee")
+                                    "-n" "-F" "-u" "bitlbee" "-c" #$conf)
+
+                              ;; Allow 'bitlbee-purple' to use libpurple plugins.
+                              #:environment-variables
+                              (list (string-append "PURPLE_PLUGIN_PATH="
+                                                   #$plugins "/lib/purple-2"))
+
+                              #:pid-file "/var/run/bitlbee.pid"
+                              #:mappings (list (file-system-mapping
+                                                (source "/var/lib/bitlbee")
+                                                (target source)
+                                                (writable? #t))))))
                 (stop  #~(make-kill-destructor)))))))))
 
 (define %bitlbee-accounts
diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm
index 202a1c2f73..1e26c0ddea 100644
--- a/gnu/tests/messaging.scm
+++ b/gnu/tests/messaging.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
-;;; Copyright © 2017, 2018, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017-2018, 2021-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -198,25 +198,6 @@ (define marionette
                 (start-service 'bitlbee))
              marionette))
 
-          (test-equal "valid PID"
-            #$(file-append bitlbee "/sbin/bitlbee")
-            (marionette-eval
-             '(begin
-                (use-modules (srfi srfi-1)
-                             (gnu services herd))
-
-                (let ((bitlbee
-                       (find (lambda (service)
-                               (equal? '(bitlbee)
-                                       (live-service-provision service)))
-                             (current-services))))
-                  (and (pk 'bitlbee-service bitlbee)
-                       (let ((pid (live-service-running bitlbee)))
-                         (readlink (string-append "/proc/"
-                                                  (number->string pid)
-                                                  "/exe"))))))
-             marionette))
-
           (test-assert "connect"
             (let* ((address (make-socket-address AF_INET INADDR_LOOPBACK
                                                  6667))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 08/12] services: ipfs: Adjust for Shepherd 0.9.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-8-ludo@gnu.org
This is a followup to e1f0c88ea221d846b5a533c4dc88e99e953af63e.

* gnu/services/networking.scm (%ipfs-activation)[shepherd&co]: New
variable.
[container-gexp]: Use it.
---
gnu/services/networking.scm | 9 ++++++++-
1 file changed, 8 insertions(+), 1 deletion(-)

Toggle diff (27 lines)
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 5bb8638930..b302be5aaf 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -2074,12 +2074,19 @@ (define inner-gexp
         #$@(map (cute apply set-config!-gexp <>) settings)))
   (define inner-script
     (program-file "ipfs-activation-inner" inner-gexp))
+
+  (define shepherd&co
+    ;; 'make-forkexec-constructor/container' needs version 0.9 for
+    ;; #:supplementary-groups.
+    (cons shepherd-0.9
+          (list (lookup-package-input shepherd-0.9 "guile-fibers"))))
+
   ;; Run ipfs init and ipfs config from a container,
   ;; in case the IPFS daemon was compromised at some point
   ;; and ~/.ipfs is now a symlink to somewhere outside
   ;; %ipfs-home.
   (define container-gexp
-    (with-extensions (list shepherd)
+    (with-extensions shepherd&co
       (with-imported-modules (source-module-closure
                               '((gnu build shepherd)
                                 (gnu system file-systems)))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 10/12] services: wesnothd: Grant write access to /var/run/wesnothd.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-10-ludo@gnu.org
* gnu/services/games.scm (wesnothd-shepherd-service): Augment 'modules'
field. Pass #:mappings argument to 'make-forkexec-constructor/container'.
(wesnothd-activation): New variable.
(wesnothd-service-type): Extend ACTIVATION-SERVICE-TYPE.
---
gnu/services/games.scm | 24 ++++++++++++++++++++++--
1 file changed, 22 insertions(+), 2 deletions(-)

Toggle diff (60 lines)
diff --git a/gnu/services/games.scm b/gnu/services/games.scm
index b743f6a4b6..dc0bfbe9dc 100644
--- a/gnu/services/games.scm
+++ b/gnu/services/games.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,18 +58,35 @@ (define wesnothd-shepherd-service
   (match-lambda
     (($ <wesnothd-configuration> package port)
      (with-imported-modules (source-module-closure
-                             '((gnu build shepherd)))
+                             '((gnu build shepherd)
+                               (gnu system file-systems)))
        (shepherd-service
         (documentation "The Battle for Wesnoth server")
         (provision '(wesnoth-daemon))
         (requirement '(networking))
-        (modules '((gnu build shepherd)))
+        (modules '((gnu build shepherd)
+                   (gnu system file-systems)))
         (start #~(make-forkexec-constructor/container
                   (list #$(file-append package "/bin/wesnothd")
                         "-p" #$(number->string port))
+                  #:mappings (list (file-system-mapping
+                                    (source "/var/run/wesnothd")
+                                    (target source)
+                                    (writable? #t)))
                   #:user "wesnothd" #:group "wesnothd"))
         (stop #~(make-kill-destructor)))))))
 
+(define wesnothd-activation
+  (with-imported-modules '((guix build utils))
+    #~(begin
+        (use-modules (guix build utils))
+
+        (let* ((user (getpw "wesnothd"))
+               (directory "/var/run/wesnothd"))
+          ;; wesnothd creates a Unix-domain socket in DIRECTORY.
+          (mkdir-p directory)
+          (chown directory (passwd:uid user) (passwd:gid user))))))
+
 (define wesnothd-service-type
   (service-type
    (name 'wesnothd)
@@ -77,6 +95,8 @@ (define wesnothd-service-type
    (extensions
     (list (service-extension account-service-type
                              (const %wesnothd-accounts))
+          (service-extension activation-service-type
+                             (const wesnothd-activation))
           (service-extension shepherd-root-service-type
                              (compose list wesnothd-shepherd-service))))
    (default-value (wesnothd-configuration))))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 11/12] services: wesnothd: Use 'least-authority-wrapper'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-11-ludo@gnu.org
* gnu/services/games.scm (wesnothd-shepherd-service): Use
'least-authority-wrapper' instead of
'make-forkexec-constructor/container'.
---
gnu/services/games.scm | 25 +++++++++++++------------
1 file changed, 13 insertions(+), 12 deletions(-)

Toggle diff (49 lines)
diff --git a/gnu/services/games.scm b/gnu/services/games.scm
index dc0bfbe9dc..6c2af44b49 100644
--- a/gnu/services/games.scm
+++ b/gnu/services/games.scm
@@ -23,6 +23,9 @@ (define-module (gnu services games)
   #:use-module (gnu packages admin)
   #:use-module (gnu packages games)
   #:use-module (gnu system shadow)
+  #:use-module ((gnu system file-systems) #:select (file-system-mapping))
+  #:use-module (gnu build linux-container)
+  #:autoload   (guix least-authority) (least-authority-wrapper)
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix records)
@@ -57,22 +60,20 @@ (define %wesnothd-accounts
 (define wesnothd-shepherd-service
   (match-lambda
     (($ <wesnothd-configuration> package port)
-     (with-imported-modules (source-module-closure
-                             '((gnu build shepherd)
-                               (gnu system file-systems)))
+     (let ((wesnothd (least-authority-wrapper
+                      (file-append package "/bin/wesnothd")
+                      #:name "wesnothd"
+                      #:mappings (list (file-system-mapping
+                                        (source "/var/run/wesnothd")
+                                        (target source)
+                                        (writable? #t)))
+                      #:namespaces (delq 'net %namespaces))))
        (shepherd-service
         (documentation "The Battle for Wesnoth server")
         (provision '(wesnoth-daemon))
         (requirement '(networking))
-        (modules '((gnu build shepherd)
-                   (gnu system file-systems)))
-        (start #~(make-forkexec-constructor/container
-                  (list #$(file-append package "/bin/wesnothd")
-                        "-p" #$(number->string port))
-                  #:mappings (list (file-system-mapping
-                                    (source "/var/run/wesnothd")
-                                    (target source)
-                                    (writable? #t)))
+        (start #~(make-forkexec-constructor
+                  (list #$wesnothd "-p" #$(number->string port))
                   #:user "wesnothd" #:group "wesnothd"))
         (stop #~(make-kill-destructor)))))))
 
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 09/12] services: ipfs: Use 'least-authority-wrapper'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-9-ludo@gnu.org
* gnu/services/networking.scm (ipfs-binary): Call
'least-authority-wrapper'.
(%ipfs-home-mapping): Remove surrounding gexp.
(ipfs-shepherd-service)[exec-command]: New procedure.
[ipfs-config-command, set-config!-gexp, shepherd&co]
[container-gexp, container-script]: Remove.
[inner-gexp]: Use 'exec-command'.
---
gnu/services/networking.scm | 123 +++++++++++++++++-------------------
1 file changed, 58 insertions(+), 65 deletions(-)

Toggle diff (181 lines)
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index b302be5aaf..4708ade0ca 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2016, 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2016 John Darrington <jmd@gnu.org>
@@ -43,6 +43,7 @@ (define-module (gnu services networking)
   #:use-module (gnu services dbus)
   #:use-module (gnu system shadow)
   #:use-module (gnu system pam)
+  #:use-module ((gnu system file-systems) #:select (file-system-mapping))
   #:use-module (gnu packages admin)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
@@ -59,6 +60,7 @@ (define-module (gnu services networking)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages ipfs)
   #:use-module (gnu build linux-container)
+  #:autoload   (guix least-authority) (least-authority-wrapper)
   #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix modules)
@@ -2018,13 +2020,20 @@ (define %ipfs-accounts
          (system? #t))))
 
 (define (ipfs-binary config)
-  (file-append (ipfs-configuration-package config) "/bin/ipfs"))
+  (define command
+    (file-append (ipfs-configuration-package config) "/bin/ipfs"))
+
+  (least-authority-wrapper
+   command
+   #:name "ipfs"
+   #:mappings (list %ipfs-home-mapping)
+   #:namespaces (delq 'net %namespaces)))
 
 (define %ipfs-home-mapping
-  #~(file-system-mapping
-     (source #$%ipfs-home)
-     (target #$%ipfs-home)
-     (writable? #t)))
+  (file-system-mapping
+   (source %ipfs-home)
+   (target %ipfs-home)
+   (writable? #t)))
 
 (define %ipfs-environment
   #~(list #$(string-append "HOME=" %ipfs-home)))
@@ -2033,82 +2042,66 @@ (define (ipfs-shepherd-service config)
   "Return a <shepherd-service> for IPFS with CONFIG."
   (define ipfs-daemon-command
     #~(list #$(ipfs-binary config) "daemon"))
-  (list
-   (with-imported-modules (source-module-closure
-                           '((gnu build shepherd)
-                             (gnu system file-systems)))
-     (shepherd-service
-      (provision '(ipfs))
-      ;; While IPFS is most useful when the machine is connected
-      ;; to the network, only loopback is required for starting
-      ;; the service.
-      (requirement '(loopback))
-      (documentation "Connect to the IPFS network")
-      (modules '((gnu build shepherd)
-                 (gnu system file-systems)))
-      (start #~(make-forkexec-constructor/container
-                #$ipfs-daemon-command
-                #:namespaces '#$(fold delq %namespaces '(user net))
-                #:mappings (list #$%ipfs-home-mapping)
-                #:log-file "/var/log/ipfs.log"
-                #:user "ipfs"
-                #:group "ipfs"
-                #:environment-variables #$%ipfs-environment))
-      (stop #~(make-kill-destructor))))))
+
+  (list (shepherd-service
+         (provision '(ipfs))
+         ;; While IPFS is most useful when the machine is connected
+         ;; to the network, only loopback is required for starting
+         ;; the service.
+         (requirement '(loopback))
+         (documentation "Connect to the IPFS network")
+         (start #~(make-forkexec-constructor
+                   #$ipfs-daemon-command
+                   #:log-file "/var/log/ipfs.log"
+                   #:user "ipfs" #:group "ipfs"
+                   #:environment-variables #$%ipfs-environment))
+         (stop #~(make-kill-destructor)))))
 
 (define (%ipfs-activation config)
   "Return an activation gexp for IPFS with CONFIG"
-  (define (ipfs-config-command setting value)
-    #~(#$(ipfs-binary config) "config" #$setting #$value))
-  (define (set-config!-gexp setting value)
-    #~(system* #$@(ipfs-config-command setting value)))
+  (define (exec-command . args)
+    ;; Exec the given ifps command with the right authority.
+    #~(let ((pid (primitive-fork)))
+        (if (zero? pid)
+            (dynamic-wind
+              (const #t)
+              (lambda ()
+                ;; Run ipfs init and ipfs config from a container,
+                ;; in case the IPFS daemon was compromised at some point
+                ;; and ~/.ipfs is now a symlink to somewhere outside
+                ;; %ipfs-home.
+                (let ((pw (getpwnam "ipfs")))
+                  (setgroups '#())
+                  (setgid (passwd:gid pw))
+                  (setuid (passwd:uid pw))
+                  (environ #$%ipfs-environment)
+                  (execl #$(ipfs-binary config) #$@args)))
+              (lambda ()
+                (primitive-exit 127)))
+            (waitpid pid))))
+
   (define settings
     `(("Addresses.API" ,(ipfs-configuration-api config))
       ("Addresses.Gateway" ,(ipfs-configuration-gateway config))))
+
   (define inner-gexp
     #~(begin
         (umask #o077)
         ;; Create $HOME/.ipfs structure
-        (system* #$(ipfs-binary config) "init")
+        #$(exec-command "ipfs" "init")
         ;; Apply settings
-        #$@(map (cute apply set-config!-gexp <>) settings)))
+        #$@(map (match-lambda
+                  ((setting value)
+                   (exec-command "ipfs" "config" setting value)))
+                settings)))
+
   (define inner-script
     (program-file "ipfs-activation-inner" inner-gexp))
 
-  (define shepherd&co
-    ;; 'make-forkexec-constructor/container' needs version 0.9 for
-    ;; #:supplementary-groups.
-    (cons shepherd-0.9
-          (list (lookup-package-input shepherd-0.9 "guile-fibers"))))
-
-  ;; Run ipfs init and ipfs config from a container,
-  ;; in case the IPFS daemon was compromised at some point
-  ;; and ~/.ipfs is now a symlink to somewhere outside
-  ;; %ipfs-home.
-  (define container-gexp
-    (with-extensions shepherd&co
-      (with-imported-modules (source-module-closure
-                              '((gnu build shepherd)
-                                (gnu system file-systems)))
-        #~(begin
-            (use-modules (gnu build shepherd)
-                         (gnu system file-systems))
-            (let* ((constructor
-                    (make-forkexec-constructor/container
-                     (list #$inner-script)
-                     #:namespaces '#$(fold delq %namespaces '(user))
-                     #:mappings (list #$%ipfs-home-mapping)
-                     #:user "ipfs"
-                     #:group "ipfs"
-                     #:environment-variables #$%ipfs-environment))
-                   (pid (constructor)))
-              (waitpid pid))))))
   ;; The activation may happen from the initrd, which uses
   ;; a statically-linked guile, while the guix container
   ;; procedures require a working dynamic-link.
-  (define container-script
-    (program-file "ipfs-activation-container" container-gexp))
-  #~(system* #$container-script))
+  #~(system* #$inner-script))
 
 (define ipfs-service-type
   (service-type
-- 
2.35.1
L
L
Ludovic Courtès wrote on 17 Apr 23:04 +0200
[PATCH 12/12] services: quassel: Use 'least-authority-wrapper'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220417210453.27884-12-ludo@gnu.org
* gnu/services/messaging.scm (quassel-shepherd-service): Use
'least-authority-wrapper' instead of
'make-forkexec-constructor/container'.
---
gnu/services/messaging.scm | 42 ++++++++++++++++++++------------------
1 file changed, 22 insertions(+), 20 deletions(-)

Toggle diff (58 lines)
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
index 7fdd8cf285..05bf6e784b 100644
--- a/gnu/services/messaging.scm
+++ b/gnu/services/messaging.scm
@@ -939,29 +939,31 @@ (define-record-type* <quassel-configuration>
 (define quassel-shepherd-service
   (match-lambda
     (($ <quassel-configuration> quassel interface port loglevel)
-     (with-imported-modules (source-module-closure
-                              '((gnu build shepherd)
-                                (gnu system file-systems)))
+     (let ((quassel (least-authority-wrapper
+                     (file-append quassel "/bin/quasselcore")
+                     #:name "quasselcore"
+                     #:mappings (list (file-system-mapping
+                                       (source "/var/lib/quassel")
+                                       (target source)
+                                       (writable? #t))
+                                      (file-system-mapping
+                                       (source "/var/log/quassel")
+                                       (target source)
+                                       (writable? #t)))
+                     ;; XXX: The daemon needs to live in the main user
+                     ;; namespace, as root, so it can access /var/lib/quassel
+                     ;; owned by "quasselcore".
+                     #:namespaces (fold delq %namespaces '(net user)))))
        (list (shepherd-service
                (provision '(quassel))
                (requirement '(user-processes networking))
-               (modules '((gnu build shepherd)
-                          (gnu system file-systems)))
-               (start #~(make-forkexec-constructor/container
-                          (list #$(file-append quassel "/bin/quasselcore")
-                                "--configdir=/var/lib/quassel"
-                                "--logfile=/var/log/quassel/core.log"
-                                (string-append "--loglevel=" #$loglevel)
-                                (string-append "--port=" (number->string #$port))
-                                (string-append "--listen=" #$interface))
-                          #:mappings (list (file-system-mapping
-                                             (source "/var/lib/quassel")
-                                             (target source)
-                                             (writable? #t))
-                                           (file-system-mapping
-                                             (source "/var/log/quassel")
-                                             (target source)
-                                             (writable? #t)))))
+               (start #~(make-forkexec-constructor
+                         (list #$quassel
+                               "--configdir=/var/lib/quassel"
+                               "--logfile=/var/log/quassel/core.log"
+                               (string-append "--loglevel=" #$loglevel)
+                               (string-append "--port=" (number->string #$port))
+                               (string-append "--listen=" #$interface))))
                (stop  #~(make-kill-destructor))))))))
 
 (define %quassel-account
-- 
2.35.1
M
M
Maxime Devos wrote on 18 Apr 11:08 +0200
Re: [bug#54997] [PATCH 09/12] services: ipfs: Use 'least-authority-wrapper'.
4eac7fd571ddafd46bcadfa2ef5c6b3e41a162ab.camel@telenet.be
Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
Toggle quote (13 lines)
> [...]
>  
>  (define (ipfs-binary config)
> -  (file-append (ipfs-configuration-package config) "/bin/ipfs"))
> +  (define command
> +    (file-append (ipfs-configuration-package config) "/bin/ipfs"))
> +
> +  (least-authority-wrapper
> +   command
> +   #:name "ipfs"
> +   #:mappings (list %ipfs-home-mapping)
> +   #:namespaces (delq 'net %namespaces)))

To simplify things later, could #:user "ipfs" and #:group "ipfs" be
added to the least-authority wrapper (and implemented in the 'least-
authority procedre)? Then ...

Toggle quote (9 lines)
> + (define (exec-command . args)
> + ;; Exec the given ifps command with the right authority.
> + #~(let ((pid (primitive-fork)))
> + (if (zero? pid)
> + (dynamic-wind
> + (const #t)
> + (lambda ()
> + ;; Run ipfs init and ipfs config from a container,
> + ;; in case the IPFS daemon was compromised at some
point
Toggle quote (12 lines)
> + ;; and ~/.ipfs is now a symlink to somewhere outside
> + ;; %ipfs-home.
> + (let ((pw (getpwnam "ipfs")))
> + (setgroups '#())
> + (setgid (passwd:gid pw))
> + (setuid (passwd:uid pw))
> + (environ #$%ipfs-environment)
> + (execl #$(ipfs-binary config) #$@args)))
> + (lambda ()
> + (primitive-exit 127)))
> + (waitpid pid))))

would become simpler as it wouldn't need to fork, exec, waitpid and
dynamic-wind. Alternatively, if associating a user and group with a
pola wrapper is problematic (*), what do you think of defining a
'system*/with-capabilities' or 'invoke/with-capabilities' in a central
location?

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYl0qchccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7gqKAP9bcMlihKJ4zbJ6MMt090nH9tQD
AWoJHwOrti+8q7jsZQEAhHs2tQxxY2kw28WCL+GuTCgcae+z5aI0xbbe/RrpAw8=
=bdj/
-----END PGP SIGNATURE-----


M
M
Maxime Devos wrote on 18 Apr 11:12 +0200
Re: [bug#54997] [PATCH 12/12] services: quassel: Use 'least-authority-wrapper'.
e8381f08894c530c3632ace441ed69f65bbd0c5d.camel@telenet.be
Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
Toggle quote (4 lines)
> +                     ;; XXX: The daemon needs to live in the main user
> +                     ;; namespace, as root, so it can access /var/lib/quassel
> +                     ;; owned by "quasselcore".

The previous code did not have this comment, was the old code broken or
is this a limitation of least-authority-wrapper?

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYl0raxccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7oj3AQDqlD5Uwhs+Y8i7CRnB2Q41Zaf5
q7/BgNetmN3ELCqrnQD8CXDyF7zPdStGdezD6kppGabu0qYkymQ/JKzkixnb1gg=
=wXdF
-----END PGP SIGNATURE-----


M
M
Maxime Devos wrote on 18 Apr 11:13 +0200
Re: [bug#54997] [PATCH 07/12] services: bitlbee: Use 'make-inetd-constructor'.
ed4de557a1e641e72f1f1d7f01a9bdac9d509f5d.camel@telenet.be
Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
Toggle quote (2 lines)
> +                (start #~(if (defined? 'make-inetd-constructor)

This is for compatibility with reconfiguring on old Shepherds I
presume? I would add a comment here

;; Only use 'make-inetd-constructor' if it exists in the current,
;; Shepherd, possibly we are reconfiguring on an old Shepherd that
;; does not yet have 'make-inetd-constructor'.

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYl0r1xccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7mvnAP9eCEiQR1vY646yqYyxe3Tp771k
MMQK/sn8klYSqHTdtwD9Ghyo3LI2z6eESXQVB8OqwnHrTaY9yT4cbd0CgJQs5As=
=qAoD
-----END PGP SIGNATURE-----


M
M
Maxime Devos wrote on 18 Apr 11:15 +0200
Re: [bug#54997] [PATCH 04/12] Add (guix least-authority).
d5131a6fdf40d8ad4cdb75583929de2441539e13.camel@telenet.be
Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
Toggle quote (4 lines)
> +(define %precious-variables
> +  ;; Environment variables preserved by the wrapper by default.
> +  '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER"))

This appears to be duplicated from (guix profiles), so there seems to
be a risk here of them going out-of-sync; would it make send for
(guix profiles) to read (guix least-authority) here?

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYl0sRhccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7j8cAP9SKNouw4e5cuyIJgUn+kBOFICs
FDCVAqT2prwAP+R3jQD+Kh5PrbA9Fw62XCyWgJ1qxSKFdJ3AXn1TX2ZfZOW1Hww=
=hkm6
-----END PGP SIGNATURE-----


M
M
Maxime Devos wrote on 18 Apr 11:18 +0200
a62e20ef622258ba101f7534a37799eaa19887e8.camel@telenet.be
Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
Toggle quote (10 lines)
> +(define* (least-authority-wrapper program
> +                                  #:key (name "pola-wrapper")
> +                                  (guest-uid 1000)
> +                                  (guest-gid 1000)
> +                                  (mappings '())
> +                                  (namespaces %namespaces)
> +                                  (directory "/")
> +                                  (preserved-environment-variables
> +                                   %precious-variables))

Could there be an option to define environment variables? E.g. set
GUIX_LOCPATH for Guile packages that need locale data to read non-ASCII
file names. As is, it seems like an environment-setting wrapper has to
be inserted inside the pola wrapper to do this.

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYl0s+RccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7ozyAQC7WElwDoy8fLphK1vPuDjEiXnE
UZMfs+qKpNvCFxtFDQD/dms9vF+wpyFA8xQdt29L3XBJYYq1tfaHE3f4ytwEGQg=
=zY+o
-----END PGP SIGNATURE-----


L
L
Ludovic Courtès wrote on 19 Apr 23:59 +0200
Re: bug#54997: [PATCH 00/12] Add "least authority" program wrapper
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 54997@debbugs.gnu.org)
878rs0raxy.fsf_-_@gnu.org
Hi Maxime,

Maxime Devos <maximedevos@telenet.be> skribis:

Toggle quote (8 lines)
> Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
>> +                     ;; XXX: The daemon needs to live in the main user
>> +                     ;; namespace, as root, so it can access /var/lib/quassel
>> +                     ;; owned by "quasselcore".
>
> The previous code did not have this comment, was the old code broken or
> is this a limitation of least-authority-wrapper?

It’s just that ‘make-forkexec-constructor/container’ does it by default:

Toggle snippet (6 lines)
(define (default-namespaces args)
;; Most daemons are here to talk to the network, and most of them expect to
;; run under a non-zero UID.
(fold delq %namespaces '(net user)))

‘least-authority-wrapper’ is stricter by defaulting to ‘%namespaces’.

Ludo’.
L
L
Ludovic Courtès wrote on 20 Apr 00:02 +0200
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 54997@debbugs.gnu.org)
8735i8ratp.fsf_-_@gnu.org
Maxime Devos <maximedevos@telenet.be> skribis:

Toggle quote (18 lines)
> Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
>> [...]
>>  
>>  (define (ipfs-binary config)
>> -  (file-append (ipfs-configuration-package config) "/bin/ipfs"))
>> +  (define command
>> +    (file-append (ipfs-configuration-package config) "/bin/ipfs"))
>> +
>> +  (least-authority-wrapper
>> +   command
>> +   #:name "ipfs"
>> +   #:mappings (list %ipfs-home-mapping)
>> +   #:namespaces (delq 'net %namespaces)))
>
> To simplify things later, could #:user "ipfs" and #:group "ipfs" be
> added to the least-authority wrapper (and implemented in the 'least-
> authority procedre)? Then ...

To me it’s setuid/setgid is beyond the scope of
‘least-authority-wrapper’. And indeed, this place is the only one that
needs it.

Toggle quote (6 lines)
> would become simpler as it wouldn't need to fork, exec, waitpid and
> dynamic-wind. Alternatively, if associating a user and group with a
> pola wrapper is problematic (*), what do you think of defining a
> 'system*/with-capabilities' or 'invoke/with-capabilities' in a central
> location?

I’m not sure what these procedures would do.

I think we should build the house one brick at a time; this is the first
brick but I’m sure there’ll be others as we gain more experience and
clearer use cases.

Ludo’.
L
L
Ludovic Courtès wrote on 20 Apr 00:03 +0200
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 54997@debbugs.gnu.org)
87y200pw7v.fsf_-_@gnu.org
Maxime Devos <maximedevos@telenet.be> skribis:

Toggle quote (6 lines)
> Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
>> +                (start #~(if (defined? 'make-inetd-constructor)
>
> This is for compatibility with reconfiguring on old Shepherds I
> presume?

Yes.

Toggle quote (6 lines)
> I would add a comment here
>
> ;; Only use 'make-inetd-constructor' if it exists in the current,
> ;; Shepherd, possibly we are reconfiguring on an old Shepherd that
> ;; does not yet have 'make-inetd-constructor'.

Will do; probably something shorter because the same pattern occurs
every time we use Shepherd 0.9 features.
L
L
Ludovic Courtès wrote on 20 Apr 00:04 +0200
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 54997@debbugs.gnu.org)
87tuaopw5v.fsf_-_@gnu.org
Maxime Devos <maximedevos@telenet.be> skribis:

Toggle quote (9 lines)
> Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
>> +(define %precious-variables
>> +  ;; Environment variables preserved by the wrapper by default.
>> +  '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER"))
>
> This appears to be duplicated from (guix profiles), so there seems to
> be a risk here of them going out-of-sync; would it make send for
> (guix profiles) to read (guix least-authority) here?

It is duplicated, but OTOH the use case is different. So I think it’s
OK to have a different definition here.

(Perhaps eventually we’ll do something fancier, like preserving
XAUTHORITY and DISPLAY if and only if we’re running an X11 program.)

Ludo’.
L
L
Ludovic Courtès wrote on 20 Apr 00:05 +0200
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 54997@debbugs.gnu.org)
87pmlcpw4c.fsf_-_@gnu.org
Maxime Devos <maximedevos@telenet.be> skribis:
Toggle quote (15 lines)
> Ludovic Courtès schreef op zo 17-04-2022 om 23:04 [+0200]:
>> +(define* (least-authority-wrapper program
>> +                                  #:key (name "pola-wrapper")
>> +                                  (guest-uid 1000)
>> +                                  (guest-gid 1000)
>> +                                  (mappings '())
>> +                                  (namespaces %namespaces)
>> +                                  (directory "/")
>> +                                  (preserved-environment-variables
>> +                                   %precious-variables))
>
> Could there be an option to define environment variables? E.g. set
> GUIX_LOCPATH for Guile packages that need locale data to read non-ASCII
> file names. As is, it seems like an environment-setting wrapper has to
> be inserted inside the pola wrapper to do this.
Yes, good point. I’m tempted to wait until the first use case comes up
though. :-)
Thanks for taking a look!
T
T
Thiago Jung Bauermann wrote on 22 Apr 07:01 +0200
Re: [bug#54997] [PATCH 01/12] gexp: Add 'references-file'.
(name . Ludovic Courtès)(address . ludo@gnu.org)
871qxpvh04.fsf@kolabnow.com
Hello Ludo,

This is an awesome series! It will be yet another strength of Guix to
have many services as possible (and even desktop apps, hopefully)
isolated.

I have one question:

Ludovic Courtès <ludo@gnu.org> writes:

Toggle quote (15 lines)
> + (define (read-graph port)
> + ;; Return the list of references read from
> + ;; PORT. This is a stripped-down version of
> + ;; 'read-reference-graph'.
> + (let loop ((items '()))
> + (match (read-line port)
> + ((? eof-object?)
> + items)
> + ((? string? item)
> + (let ((deriver (read-line port))
> + (count
> + (string->number (read-line port))))
> + (drop-lines port count)
> + (loop (cons item items)))))))

I'm sure I'm being dense, but I don't see how ‘item’ can change between
iterations of this loop. Which in my mind means that ‘read-graph’ can
only return a list where the original ‘item’ argument from
‘references-file’ is repeated many times over. I ran the tests/gexp.scm
test and all tests pass, so this code must be working...

--
Thanks
Thiago
M
M
Maxime Devos wrote on 22 Apr 16:39 +0200
Re: bug#54997: [PATCH 00/12] Add "least authority" program wrapper
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 54997@debbugs.gnu.org)
616af1474c44d6c1caf71fa1f9d263ff46462201.camel@telenet.be
Ludovic Courtès schreef op wo 20-04-2022 om 00:02 [+0200]:
Toggle quote (14 lines)
> > would become simpler as it wouldn't need to fork, exec, waitpid and
> > dynamic-wind.  Alternatively, if associating a user and group with
> > a
> > pola wrapper is problematic (*), what do you think of defining a
> > 'system*/with-capabilities' or 'invoke/with-capabilities' in a
> > central
> > location?
>
> I’m not sure what these procedures would do.
>
> I think we should build the house one brick at a time; this is the
> first brick but I’m sure there’ll be others as we gain more
> experience and clearer use cases.

This system*/with-capabilities brick would do the primitive-
fork+setuid+setgid+execl thing:

(define (system*/with-capabilities command #:key user group extra-
groups environment)
;; Exec the given command with the right authority.
(let ((pid (primitive-fork)))
(if (zero? pid)
(dynamic-wind
(const #t)
(lambda ()
(let ((pw (getpwnam "ipfs"))) ; TODO use 'user' and
'group', and don't change user/group when already this user/group
(setgroups '#())
(setgid (passwd:gid pw))
(setuid (passwd:uid pw))
(environ environment)
(apply execl command)))
(lambda ()
(primitive-exit 127)))
(waitpid pid)))))

This would make this functionality available outside the ipfs service
as well. Over time, it could be extended to support more kinds of
ambient authority, e.g. namespaces, POSIX ‘capabilities’, capability
masks to disallow gaining capabilities by runningsetuid binaries, the
file system hierarchy (with bind mounts), removing all users and groups
(on the Hurd), ...

Many of these are supported by 'least-authority-wrapper' but these POLA
wrappers require creating an additional process which seems a bit
unoptimal to me (memory- and latency-wise).

Also, having to do fork, waitpid and primitive-fork seems rather low-
level to me, so I prefer moving this code into somewhere like (gnu
build SOMEWHERE) or to keep the old make-forkexec-constructor/container
code.

Greetinsgs,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYmK+LxccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7lfjAPwOb8rRVbIKCwU+IST9lYnmN3P3
wlsYxC8ttytRHwo84QD/X/Yrav9MciSAp6fxdWaWviXJcHndzknX7YhFDE5GVAk=
=RY56
-----END PGP SIGNATURE-----


M
M
Maxime Devos wrote on 22 Apr 17:02 +0200
Re: [bug#54997] [PATCH 00/12] Add "least authority" program wrapper
22c9f92c9855e36b23ec70ba53fc6cf85c918527.camel@telenet.be
Ludovic Courtès schreef op zo 17-04-2022 om 23:01 [+0200]:
Toggle quote (11 lines)
> Hello Guix!
>
> So we have this fancy ‘make-forkexec-constructor/container’ thing
> to spawn Shepherd services in a container:
>
>   https://guix.gnu.org/en/blog/2017/running-system-services-in-containers/
>
> It’s nice, but it doesn’t compose.  What if you want an inetd-style
> service *and* have it run in a container?  We certainly don’t want to
> end up defining ‘make-inetd-constructor/container’ and so on.

Currently, it doesn't compose, but can it be made composable?
More concretely, maybe there could be a set of ‘process procedures’
implementable by record types:

;; with some differences
(define (subprocess-start/separate process) ...) ; run it in a separate process
(define (subprocess-start/replace process) ...) ; run it with 'exec'
(define (subprocess-kill process) ...)
(define (subprocess-wait process) ...)
(define (subprocess-status process) ...)

;; Basic process constructor, doesn't do containers
(define (command-process ...) ...)

;; Container
(define (contain inner #:key container-stuff ...)
subprocess-start/separate: (run-container ... (lambda () (subprocess-start/replace inner)))
other procedures ...
return the record)

Then make-inetd-constructor could be changed to accept a lambda producing
'subprocess' records. By passing it a subprocess wrapped by 'contain', it would
automatically support container things:

(define (make-inetd-constructor/container-command command* ...)
(make-inetd-constructor (lambda () (contain (command-process comand*))) ...))

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYmLDaxccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7uOLAQCi9Lr0I3X6G9IONhGC47M27KLn
kIEok/pwDe7zDrsn4gD/djKF+dMXUW6FG4YZFQR/9YygHh9GXjvV333oDyKzVwY=
=kY+Z
-----END PGP SIGNATURE-----


T
T
Thiago Jung Bauermann wrote on 22 Apr 22:10 +0200
Re: [bug#54997] [PATCH 04/12] Add (guix least-authority).
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 54997@debbugs.gnu.org)
87h76klv6j.fsf@kolabnow.com
Hello,

Ludovic Courtès <ludo@gnu.org> writes:
Toggle quote (7 lines)
> + (reify-exit-status
> + (call-with-container mounts
> + (lambda ()
> + (chdir #$directory)
> + (environ variables)
> + (apply execl #$program #$program (cdr (command-line))))

I'm a bit concerned about running arbitrary commands as PID 1 of process
namespaces. A process running as PID 1 (even in a child namespace) is a
special case and is treated differently by the Linux kernel than any
other process, so it needs to be a program that has been designed to
work in that situation. There are two differences from regular
processes:

1. PID 1 inherits orphan processes and needs to wait() on them when they
quit, in order to avoid accumulating zombie processes in the system.

2. Unlike regular processes, PID 1 doesn't have default signal handlers.

Both of these aspects are described in more detail here:


So to avoid an accumulation of zombie processes and other signal-related
problems, I suggest adding a “(init-program ,tini)” parameter to
‘least-authority-wrapper’ and executing ‘program’ as a subprocess of
‘tini’ or whatever was passed as the #:init-program (perhaps #f could
mean running ‘program’ directly as PID 1).

I mention this because I'm currently dealing with a problem that has
exactly this root cause: I'm working on updating the public-inbox
package to the latest version, and the testsuite is failing because it
tests that lei's daemon process is correctly terminated. But that
doesn't work because “guix build” doesn't use a proper init program as
PID 1 and thus the daemon process goes to zombie state and the testsuite
thinks that it didn't go away. I'm hoping to send a patch to fix that
issue.

--
Thanks
Thiago
L
L
Ludovic Courtès wrote on 26 Apr 22:17 +0200
Re: bug#54997: [PATCH 00/12] Add "least authority" program wrapper
(name . Thiago Jung Bauermann)(address . bauermann@kolabnow.com)(address . 54997@debbugs.gnu.org)
874k2flhuf.fsf_-_@gnu.org
Hi Thiago,

Thiago Jung Bauermann <bauermann@kolabnow.com> skribis:

Toggle quote (4 lines)
> This is an awesome series! It will be yet another strength of Guix to
> have many services as possible (and even desktop apps, hopefully)
> isolated.

Thanks. :-)

Toggle quote (20 lines)
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> + (define (read-graph port)
>> + ;; Return the list of references read from
>> + ;; PORT. This is a stripped-down version of
>> + ;; 'read-reference-graph'.
>> + (let loop ((items '()))
>> + (match (read-line port)
>> + ((? eof-object?)
>> + items)
>> + ((? string? item)
>> + (let ((deriver (read-line port))
>> + (count
>> + (string->number (read-line port))))
>> + (drop-lines port count)
>> + (loop (cons item items)))))))
>
> I'm sure I'm being dense, but I don't see how ‘item’ can change between
> iterations of this loop.

Each iteration reads a new line from PORT, an input port on a text file.

The file is created by guix-daemon and has a format like this:

FILE
DERIVER
NUMBER-OF-REFERENCES
REF1
...
REFN

where each FILE is a store item (see store-copy.scm for details).

Here we only care about FILE and REF*.

Toggle quote (5 lines)
> Which in my mind means that ‘read-graph’ can only return a list where
> the original ‘item’ argument from ‘references-file’ is repeated many
> times over. I ran the tests/gexp.scm test and all tests pass, so this
> code must be working...

I think it does! :-) It wouldn’t hurt to add a call to
‘delete-duplicates’ though.

Ludo’.
L
L
Ludovic Courtès wrote on 26 Apr 22:22 +0200
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 54997@debbugs.gnu.org)
87y1zrk31p.fsf_-_@gnu.org
Hi Maxime,

Maxime Devos <maximedevos@telenet.be> skribis:

Toggle quote (40 lines)
> Ludovic Courtès schreef op zo 17-04-2022 om 23:01 [+0200]:
>> Hello Guix!
>>
>> So we have this fancy ‘make-forkexec-constructor/container’ thing
>> to spawn Shepherd services in a container:
>>
>>   https://guix.gnu.org/en/blog/2017/running-system-services-in-containers/
>>
>> It’s nice, but it doesn’t compose.  What if you want an inetd-style
>> service *and* have it run in a container?  We certainly don’t want to
>> end up defining ‘make-inetd-constructor/container’ and so on.
>
> Currently, it doesn't compose, but can it be made composable?
> More concretely, maybe there could be a set of ‘process procedures’
> implementable by record types:
>
> ;; Inspired by <https://docs.racket-lang.org/reference/subprocess.html>,
> ;; with some differences
> (define (subprocess-start/separate process) ...) ; run it in a separate process
> (define (subprocess-start/replace process) ...) ; run it with 'exec'
> (define (subprocess-kill process) ...)
> (define (subprocess-wait process) ...)
> (define (subprocess-status process) ...)
>
> ;; Basic process constructor, doesn't do containers
> (define (command-process ...) ...)
>
> ;; Container
> (define (contain inner #:key container-stuff ...)
> subprocess-start/separate: (run-container ... (lambda () (subprocess-start/replace inner)))
> other procedures ...
> return the record)
>
> Then make-inetd-constructor could be changed to accept a lambda producing
> 'subprocess' records. By passing it a subprocess wrapped by 'contain', it would
> automatically support container things:
>
> (define (make-inetd-constructor/container-command command* ...)
> (make-inetd-constructor (lambda () (contain (command-process comand*))) ...))

A (sub)process abstraction could be useful, indeed.

But like you write, we’d need further changes in shepherd itself, which
makes it less appealing IMO. I like that the “POLA wrapper” allows us
to deal with this aspect in a fairly orthogonal fashion.

Thanks!

Ludo’.
L
L
Ludovic Courtès wrote on 26 Apr 22:30 +0200
(name . Thiago Jung Bauermann)(address . bauermann@kolabnow.com)(address . 54997@debbugs.gnu.org)
87o80nk2o8.fsf_-_@gnu.org
Hi!

Thiago Jung Bauermann <bauermann@kolabnow.com> skribis:

Toggle quote (12 lines)
> I'm a bit concerned about running arbitrary commands as PID 1 of process
> namespaces. A process running as PID 1 (even in a child namespace) is a
> special case and is treated differently by the Linux kernel than any
> other process, so it needs to be a program that has been designed to
> work in that situation. There are two differences from regular
> processes:
>
> 1. PID 1 inherits orphan processes and needs to wait() on them when they
> quit, in order to avoid accumulating zombie processes in the system.
>
> 2. Unlike regular processes, PID 1 doesn't have default signal handlers.

Good points.

Toggle quote (10 lines)
> Both of these aspects are described in more detail here:
>
> https://github.com/krallin/tini/issues/8#issuecomment-146135930
>
> So to avoid an accumulation of zombie processes and other signal-related
> problems, I suggest adding a “(init-program ,tini)” parameter to
> ‘least-authority-wrapper’ and executing ‘program’ as a subprocess of
> ‘tini’ or whatever was passed as the #:init-program (perhaps #f could
> mean running ‘program’ directly as PID 1).

Hmm yes. It’s not great that the choice is between ‘unshare’—efficient
but the process lives in the parent PID namespace—and ‘clone’—but then
you have to fork twice.

But yeah, you’re right. I’ll try what you suggest and send a v2.

Toggle quote (9 lines)
> I mention this because I'm currently dealing with a problem that has
> exactly this root cause: I'm working on updating the public-inbox
> package to the latest version, and the testsuite is failing because it
> tests that lei's daemon process is correctly terminated. But that
> doesn't work because “guix build” doesn't use a proper init program as
> PID 1 and thus the daemon process goes to zombie state and the testsuite
> thinks that it didn't go away. I'm hoping to send a patch to fix that
> issue.

Now that you mention it, this was discussed before:


I think we should do something about it in gnu-build-system.scm.

Thanks for your feedback!

Ludo’.
L
L
Ludovic Courtès wrote on 26 Apr 22:48 +0200
(name . Thiago Jung Bauermann)(address . bauermann@kolabnow.com)(address . 54997@debbugs.gnu.org)
878rrrk1v1.fsf_-_@gnu.org
Thiago Jung Bauermann <bauermann@kolabnow.com> skribis:

Toggle quote (12 lines)
> I'm a bit concerned about running arbitrary commands as PID 1 of process
> namespaces. A process running as PID 1 (even in a child namespace) is a
> special case and is treated differently by the Linux kernel than any
> other process, so it needs to be a program that has been designed to
> work in that situation. There are two differences from regular
> processes:
>
> 1. PID 1 inherits orphan processes and needs to wait() on them when they
> quit, in order to avoid accumulating zombie processes in the system.
>
> 2. Unlike regular processes, PID 1 doesn't have default signal handlers.

Actually right now ‘make-forkexec-constructor/container’ runs processes
as PID 1.

AFAIK this hasn’t been a problem in practice, probably for two reasons:
(1) we’re wrapping daemons that don’t fork (unlike Jenkins…), and (2)
‘call-with-container’ installs a SIGINT handler and probably daemons
also install SIGTERM and related handlers of their own.

Anyway, it’s a class of problem that would be best avoided in the first
place!

Ludo’.
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 01/15] gexp: Add 'references-file'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-2-ludo@gnu.org
* gnu/services/base.scm (references-file): Remove.
* guix/gexp.scm (references-file): New procedure.
* tests/gexp.scm ("references-file"): New test.
---
gnu/services/base.scm | 22 ----------------------
guix/gexp.scm | 44 +++++++++++++++++++++++++++++++++++++++++++
tests/gexp.scm | 18 ++++++++++++++++++
3 files changed, 62 insertions(+), 22 deletions(-)

Toggle diff (133 lines)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 5d7c69a9cd..182badd97f 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -219,8 +219,6 @@ (define-module (gnu services base)
             pam-limits-service-type
             pam-limits-service
 
-            references-file
-
             %base-services))
 
 ;;; Commentary:
@@ -1768,26 +1766,6 @@ (define (guix-activation config)
               (substitute-key-authorization authorized-keys guix)
               #~#f))))
 
-(define* (references-file item #:optional (name "references"))
-  "Return a file that contains the list of references of ITEM."
-  (if (struct? item)                              ;lowerable object
-      (computed-file name
-                     (with-extensions (list guile-gcrypt) ;for store-copy
-                       (with-imported-modules (source-module-closure
-                                               '((guix build store-copy)))
-                         #~(begin
-                             (use-modules (guix build store-copy))
-
-                             (call-with-output-file #$output
-                               (lambda (port)
-                                 (write (map store-info-item
-                                             (call-with-input-file "graph"
-                                               read-reference-graph))
-                                        port))))))
-                     #:options `(#:local-build? #f
-                                 #:references-graphs (("graph" ,item))))
-      (plain-file name "()")))
-
 (define guix-service-type
   (service-type
    (name 'guix)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 9fdb7a30be..ef92223048 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -118,6 +118,7 @@ (define-module (guix gexp)
             mixed-text-file
             file-union
             directory-union
+            references-file
 
             imported-files
             imported-modules
@@ -2173,6 +2174,49 @@ (define log-port
                                            #:resolve-collision
                                            (ungexp resolve-collision)))))))))
 
+(define* (references-file item #:optional (name "references")
+                          #:key guile)
+  "Return a file that contains the list of direct and indirect references (the
+closure) of ITEM."
+  (if (struct? item)                              ;lowerable object
+      (computed-file name
+                     (gexp (begin
+                             (use-modules (srfi srfi-1)
+                                          (ice-9 rdelim)
+                                          (ice-9 match))
+
+                             (define (drop-lines port n)
+                               ;; Drop N lines read from PORT.
+                               (let loop ((n n))
+                                 (unless (zero? n)
+                                   (read-line port)
+                                   (loop (- n 1)))))
+
+                             (define (read-graph port)
+                               ;; Return the list of references read from
+                               ;; PORT.  This is a stripped-down version of
+                               ;; 'read-reference-graph'.
+                               (let loop ((items '()))
+                                 (match (read-line port)
+                                   ((? eof-object?)
+                                    (delete-duplicates items))
+                                   ((? string? item)
+                                    (let ((deriver (read-line port))
+                                          (count
+                                           (string->number (read-line port))))
+                                      (drop-lines port count)
+                                      (loop (cons item items)))))))
+
+                             (call-with-output-file (ungexp output)
+                               (lambda (port)
+                                 (write (call-with-input-file "graph"
+                                          read-graph)
+                                        port)))))
+                     #:guile guile
+                     #:options `(#:local-build? #t
+                                 #:references-graphs (("graph" ,item))))
+      (plain-file name "()")))
+
 
 ;;;
 ;;; Syntactic sugar.
diff --git a/tests/gexp.scm b/tests/gexp.scm
index c80ca13fab..35bd99e6d4 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1606,6 +1606,24 @@ (define (contents=? file str)
                    (not (member (derivation-file-name native) refs))
                    (member (derivation-file-name cross) refs))))))
 
+(test-assertm "references-file"
+  (let* ((exp      #~(symlink #$%bootstrap-guile #$output))
+         (computed (computed-file "computed" exp
+                                  #:guile %bootstrap-guile))
+         (refs     (references-file computed "refs"
+                                    #:guile %bootstrap-guile)))
+    (mlet* %store-monad ((drv0 (lower-object %bootstrap-guile))
+                         (drv1 (lower-object computed))
+                         (drv2 (lower-object refs)))
+      (mbegin %store-monad
+        (built-derivations (list drv2))
+        (mlet %store-monad ((refs ((store-lift requisites)
+                                   (list (derivation->output-path drv1)))))
+          (return (lset= string=?
+                         (call-with-input-file (derivation->output-path drv2)
+                           read)
+                         refs)))))))
+
 (test-assert "lower-object & gexp-input-error?"
   (guard (c ((gexp-input-error? c)
              (gexp-error-invalid-input c)))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 00/15] Add "least authority" program wrapper
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-1-ludo@gnu.org
Hi!

Changes since v1:

• Add ‘delete-duplicates’ call in ‘references-file’.

• Work around unreliable signal delivery in Guile (note that
this is not a new problem; I just happened to notice it).
This part is unsatisfactory. The solution in the Shepherd is
signalfd(2) on GNU/Linux, but using it requires quite a bit
of infrastructure.

• New #:child-is-pid1? parameter for ‘call-with-container’, set
to #false by ‘least-authority-wrapper’. This is probably
overkill for most cases (daemons that, unlike Jenkins, don’t
run arbitrary user scripts are unlikely to leave zombies
behind them), but safer.

• Converted opendht service to ‘least-authority-wrapper’.

I think it’s good to go.

Thoughts?

Thanks,
Ludo’.

Ludovic Courtès (15):
gexp: Add 'references-file'.
file-systems: Avoid load-time warnings when attempting to load (guix
store).
linux-container: 'call-with-container' relays SIGTERM and SIGINT.
linux-container: Ensure signal-handling asyncs get a chance to run.
linux-container: Add #:child-is-pid1? parameter to
'call-with-container'.
Add (guix least-authority).
services: dicod: Rewrite using 'least-authority-wrapper'.
services: dicod: Use 'make-inetd-constructor'.
services: bitlbee: Use 'make-inetd-constructor'.
services: ipfs: Adjust for Shepherd 0.9.
services: ipfs: Use 'least-authority-wrapper'.
services: wesnothd: Grant write access to /var/run/wesnothd.
services: wesnothd: Use 'least-authority-wrapper'.
services: quassel: Use 'least-authority-wrapper'.
services: opendht: Use 'least-authority-wrapper'.

Makefile.am | 1 +
gnu/build/linux-container.scm | 78 +++++++++++++++--
gnu/build/shepherd.scm | 3 +-
gnu/services/base.scm | 22 -----
gnu/services/dict.scm | 61 ++++++++-----
gnu/services/games.scm | 33 +++++--
gnu/services/messaging.scm | 105 ++++++++++++++--------
gnu/services/networking.scm | 158 +++++++++++++++++-----------------
gnu/system/file-systems.scm | 5 +-
gnu/tests/messaging.scm | 21 +----
guix/gexp.scm | 44 ++++++++++
guix/least-authority.scm | 135 +++++++++++++++++++++++++++++
tests/gexp.scm | 18 ++++
13 files changed, 491 insertions(+), 193 deletions(-)
create mode 100644 guix/least-authority.scm


base-commit: 950f3e4f98add14f645dc4c9f8c512cac7b8a779
--
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 02/15] file-systems: Avoid load-time warnings when attempting to load (guix store).
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-3-ludo@gnu.org
This makes sure warnings like "incompatible bytecode version" don't go
through when looking for (guix store).

* gnu/system/file-systems.scm (%store-prefix): Parameterize
'current-warning-port' around 'resolve-module' call.
---
gnu/system/file-systems.scm | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)

Toggle diff (23 lines)
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 437f8da898..f8f4276283 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Google LLC
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -272,7 +272,8 @@ (define (%store-prefix)
   ;; Note: If we have (guix store database) in the search path and we do *not*
   ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
   ;; with one sub-module.
-  (cond ((and=> (resolve-module '(guix store) #:ensure #f)
+  (cond ((and=> (parameterize ((current-warning-port (%make-void-port "w0")))
+                  (resolve-module '(guix store) #:ensure #f))
                 (lambda (store)
                   (module-variable store '%store-prefix)))
          =>
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 03/15] linux-container: 'call-with-container' relays SIGTERM and SIGINT.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-4-ludo@gnu.org
* gnu/build/linux-container.scm (call-with-container): Add #:relayed-signals.
[install-signal-handlers]: New procedure.
Call it.
---
gnu/build/linux-container.scm | 20 ++++++++++++++------
1 file changed, 14 insertions(+), 6 deletions(-)

Toggle diff (48 lines)
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index bdeca2cdb9..03c01439ce 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -303,6 +303,7 @@ (define (call-with-temporary-directory proc)
 
 (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
                               (host-uids 1) (guest-uid 0) (guest-gid 0)
+                              (relayed-signals (list SIGINT SIGTERM))
                               (process-spawned-hook (const #t)))
   "Run THUNK in a new container process and return its exit status; call
 PROCESS-SPAWNED-HOOK with the PID of the new process that has been spawned.
@@ -320,20 +321,27 @@ (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
 GUEST-UID and GUEST-GID specify the first UID (respectively GID) that host
 UIDs (respectively GIDs) map to in the namespace.
 
+RELAYED-SIGNALS is the list of signals that are \"relayed\" to the container
+process when caught by its parent.
+
 Note that if THUNK needs to load any additional Guile modules, the relevant
 module files must be present in one of the mappings in MOUNTS and the Guile
 load path must be adjusted as needed."
+  (define (install-signal-handlers pid)
+    ;; Install handlers that forward signals to PID.
+    (define (relay-signal signal)
+      (false-if-exception (kill pid signal)))
+
+    (for-each (lambda (signal)
+                (sigaction signal relay-signal))
+              relayed-signals))
+
   (call-with-temporary-directory
    (lambda (root)
      (let ((pid (run-container root mounts namespaces host-uids thunk
                                #:guest-uid guest-uid
                                #:guest-gid guest-gid)))
-       ;; Catch SIGINT and kill the container process.
-       (sigaction SIGINT
-         (lambda (signum)
-           (false-if-exception
-            (kill pid SIGKILL))))
-
+       (install-signal-handlers pid)
        (process-spawned-hook pid)
        (match (waitpid pid)
          ((_ . status) status))))))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 04/15] linux-container: Ensure signal-handling asyncs get a chance to run.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-5-ludo@gnu.org
Previously we could enter the blocking 'waitpid' call and miss an
opportunity to run the signal handler async.

* gnu/build/linux-container.scm (call-with-container)
[periodically-schedule-asyncs]: New procedure.
[install-signal-handlers]: Call it.
---
gnu/build/linux-container.scm | 9 +++++++++
1 file changed, 9 insertions(+)

Toggle diff (27 lines)
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 03c01439ce..1fac8f4b92 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -327,11 +327,20 @@ (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
 Note that if THUNK needs to load any additional Guile modules, the relevant
 module files must be present in one of the mappings in MOUNTS and the Guile
 load path must be adjusted as needed."
+  (define (periodically-schedule-asyncs)
+    ;; XXX: In Guile there's a time window where a signal-handling async could
+    ;; be queued without being processed by the time we enter a blocking
+    ;; syscall like waitpid(2) (info "(guile) Signals").  This terrible hack
+    ;; ensures pending asyncs get a chance to run periodically.
+    (sigaction SIGALRM (lambda _ (alarm 1)))
+    (alarm 1))
+
   (define (install-signal-handlers pid)
     ;; Install handlers that forward signals to PID.
     (define (relay-signal signal)
       (false-if-exception (kill pid signal)))
 
+    (periodically-schedule-asyncs)
     (for-each (lambda (signal)
                 (sigaction signal relay-signal))
               relayed-signals))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 05/15] linux-container: Add #:child-is-pid1? parameter to 'call-with-container'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-6-ludo@gnu.org
* gnu/build/linux-container.scm (wait-child-process)
(status->exit-status): New procedures.
(call-with-container): Add #:child-is-pid1? parameter and honor it.
[thunk*]: New variable. Pass it to 'run-container'.
---
gnu/build/linux-container.scm | 49 ++++++++++++++++++++++++++++++++++-
1 file changed, 48 insertions(+), 1 deletion(-)

Toggle diff (82 lines)
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 1fac8f4b92..a0c8174721 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -301,9 +301,28 @@ (define (call-with-temporary-directory proc)
       (lambda ()
         (false-if-exception (delete-file-recursively tmp-dir))))))
 
+(define (wait-child-process)
+  "Wait for one child process and return a pair, like 'waitpid', or return #f
+if there are no child processes left."
+  (catch 'system-error
+    (lambda ()
+      (waitpid WAIT_ANY))
+    (lambda args
+      (if (= ECHILD (system-error-errno args))
+          #f
+          (apply throw args)))))
+
+(define (status->exit-status status)
+  "Reify STATUS as an exit status."
+  (or (status:exit-val status)
+      ;; See <http://www.tldp.org/LDP/abs/html/exitcodes.html#EXITCODESREF>.
+      (+ 128 (or (status:term-sig status)
+                 (status:stop-sig status)))))
+
 (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
                               (host-uids 1) (guest-uid 0) (guest-gid 0)
                               (relayed-signals (list SIGINT SIGTERM))
+                              (child-is-pid1? #t)
                               (process-spawned-hook (const #t)))
   "Run THUNK in a new container process and return its exit status; call
 PROCESS-SPAWNED-HOOK with the PID of the new process that has been spawned.
@@ -324,9 +343,37 @@ (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
 RELAYED-SIGNALS is the list of signals that are \"relayed\" to the container
 process when caught by its parent.
 
+When CHILD-IS-PID1? is true, and if NAMESPACES contains 'pid', then the child
+process runs directly as PID 1.  As such, it is responsible for (1) installing
+signal handlers and (2) reaping terminated processes by calling 'waitpid'.
+When CHILD-IS-PID1? is false, a new intermediate process is created instead
+that takes this responsibility.
+
 Note that if THUNK needs to load any additional Guile modules, the relevant
 module files must be present in one of the mappings in MOUNTS and the Guile
 load path must be adjusted as needed."
+  (define thunk*
+    (if (and (memq 'pid namespaces)
+             (not child-is-pid1?))
+        (lambda ()
+          ;; Behave like an init process: create a sub-process that calls
+          ;; THUNK, and wait for child processes.  Furthermore, forward
+          ;; RELAYED-SIGNALS to the child process.
+          (match (primitive-fork)
+            (0
+             (call-with-clean-exit thunk))
+            (pid
+             (install-signal-handlers pid)
+             (let loop ()
+               (match (wait-child-process)
+                 ((child . status)
+                  (if (= child pid)
+                      (primitive-exit (status->exit-status status))
+                      (loop)))
+                 (#f
+                  (primitive-exit 128)))))))      ;cannot happen
+        thunk))
+
   (define (periodically-schedule-asyncs)
     ;; XXX: In Guile there's a time window where a signal-handling async could
     ;; be queued without being processed by the time we enter a blocking
@@ -347,7 +394,7 @@ (define (relay-signal signal)
 
   (call-with-temporary-directory
    (lambda (root)
-     (let ((pid (run-container root mounts namespaces host-uids thunk
+     (let ((pid (run-container root mounts namespaces host-uids thunk*
                                #:guest-uid guest-uid
                                #:guest-gid guest-gid)))
        (install-signal-handlers pid)
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 12/15] services: wesnothd: Grant write access to /var/run/wesnothd.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-13-ludo@gnu.org
* gnu/services/games.scm (wesnothd-shepherd-service): Augment 'modules'
field. Pass #:mappings argument to 'make-forkexec-constructor/container'.
(wesnothd-activation): New variable.
(wesnothd-service-type): Extend ACTIVATION-SERVICE-TYPE.
---
gnu/services/games.scm | 24 ++++++++++++++++++++++--
1 file changed, 22 insertions(+), 2 deletions(-)

Toggle diff (60 lines)
diff --git a/gnu/services/games.scm b/gnu/services/games.scm
index b743f6a4b6..dc0bfbe9dc 100644
--- a/gnu/services/games.scm
+++ b/gnu/services/games.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,18 +58,35 @@ (define wesnothd-shepherd-service
   (match-lambda
     (($ <wesnothd-configuration> package port)
      (with-imported-modules (source-module-closure
-                             '((gnu build shepherd)))
+                             '((gnu build shepherd)
+                               (gnu system file-systems)))
        (shepherd-service
         (documentation "The Battle for Wesnoth server")
         (provision '(wesnoth-daemon))
         (requirement '(networking))
-        (modules '((gnu build shepherd)))
+        (modules '((gnu build shepherd)
+                   (gnu system file-systems)))
         (start #~(make-forkexec-constructor/container
                   (list #$(file-append package "/bin/wesnothd")
                         "-p" #$(number->string port))
+                  #:mappings (list (file-system-mapping
+                                    (source "/var/run/wesnothd")
+                                    (target source)
+                                    (writable? #t)))
                   #:user "wesnothd" #:group "wesnothd"))
         (stop #~(make-kill-destructor)))))))
 
+(define wesnothd-activation
+  (with-imported-modules '((guix build utils))
+    #~(begin
+        (use-modules (guix build utils))
+
+        (let* ((user (getpw "wesnothd"))
+               (directory "/var/run/wesnothd"))
+          ;; wesnothd creates a Unix-domain socket in DIRECTORY.
+          (mkdir-p directory)
+          (chown directory (passwd:uid user) (passwd:gid user))))))
+
 (define wesnothd-service-type
   (service-type
    (name 'wesnothd)
@@ -77,6 +95,8 @@ (define wesnothd-service-type
    (extensions
     (list (service-extension account-service-type
                              (const %wesnothd-accounts))
+          (service-extension activation-service-type
+                             (const wesnothd-activation))
           (service-extension shepherd-root-service-type
                              (compose list wesnothd-shepherd-service))))
    (default-value (wesnothd-configuration))))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 10/15] services: ipfs: Adjust for Shepherd 0.9.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-11-ludo@gnu.org
This is a followup to e1f0c88ea221d846b5a533c4dc88e99e953af63e.

* gnu/services/networking.scm (%ipfs-activation)[shepherd&co]: New
variable.
[container-gexp]: Use it.
---
gnu/services/networking.scm | 9 ++++++++-
1 file changed, 8 insertions(+), 1 deletion(-)

Toggle diff (27 lines)
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 5bb8638930..b302be5aaf 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -2074,12 +2074,19 @@ (define inner-gexp
         #$@(map (cute apply set-config!-gexp <>) settings)))
   (define inner-script
     (program-file "ipfs-activation-inner" inner-gexp))
+
+  (define shepherd&co
+    ;; 'make-forkexec-constructor/container' needs version 0.9 for
+    ;; #:supplementary-groups.
+    (cons shepherd-0.9
+          (list (lookup-package-input shepherd-0.9 "guile-fibers"))))
+
   ;; Run ipfs init and ipfs config from a container,
   ;; in case the IPFS daemon was compromised at some point
   ;; and ~/.ipfs is now a symlink to somewhere outside
   ;; %ipfs-home.
   (define container-gexp
-    (with-extensions (list shepherd)
+    (with-extensions shepherd&co
       (with-imported-modules (source-module-closure
                               '((gnu build shepherd)
                                 (gnu system file-systems)))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 08/15] services: dicod: Use 'make-inetd-constructor'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-9-ludo@gnu.org
* gnu/services/dict.scm (dicod-shepherd-service): Use
'make-inetd-constructor' in the 'start' method when available.
---
gnu/services/dict.scm | 18 ++++++++++++++----
1 file changed, 14 insertions(+), 4 deletions(-)

Toggle diff (38 lines)
diff --git a/gnu/services/dict.scm b/gnu/services/dict.scm
index 62b21f8d53..109917c05c 100644
--- a/gnu/services/dict.scm
+++ b/gnu/services/dict.scm
@@ -146,6 +146,7 @@ (define %dicod-activation
 
 (define (dicod-shepherd-service config)
   (let* ((dicod.conf (dicod-configuration-file config))
+         (interfaces (dicod-configuration-interfaces config))
          (dicod      (least-authority-wrapper
                       (file-append (dicod-configuration-dico config)
                                    "/bin/dicod")
@@ -165,10 +166,19 @@ (define (dicod-shepherd-service config)
            (provision '(dicod))
            (requirement '(user-processes))
            (documentation "Run the dicod daemon.")
-           (start #~(make-forkexec-constructor
-                     (list #$dicod "--foreground"
-                           (string-append "--config=" #$dicod.conf))
-                     #:user "dicod" #:group "dicod"))
+           (start #~(if (and (defined? 'make-inetd-constructor)
+                             #$(= 1 (length interfaces))) ;XXX
+                        (make-inetd-constructor
+                         (list #$dicod "--inetd" "--foreground"
+                               (string-append "--config=" #$dicod.conf))
+                         (addrinfo:addr
+                          (car (getaddrinfo #$(first interfaces) "dict")))
+                         #:user "dicod" #:group "dicod"
+                         #:service-name-stem "dicod")
+                        (make-forkexec-constructor
+                         (list #$dicod "--foreground"
+                               (string-append "--config=" #$dicod.conf))
+                         #:user "dicod" #:group "dicod")))
            (stop #~(make-kill-destructor))))))
 
 (define dicod-service-type
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 06/15] Add (guix least-authority).
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-7-ludo@gnu.org
* guix/least-authority.scm: New file.
* Makefile.am (MODULES): Add it.
* gnu/build/shepherd.scm (default-mounts): Make public.
---
Makefile.am | 1 +
gnu/build/shepherd.scm | 3 +-
guix/least-authority.scm | 135 +++++++++++++++++++++++++++++++++++++++
3 files changed, 138 insertions(+), 1 deletion(-)
create mode 100644 guix/least-authority.scm

Toggle diff (169 lines)
diff --git a/Makefile.am b/Makefile.am
index fecce7c6f7..d0d58da4e3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -130,6 +130,7 @@ MODULES =					\
   guix/cache.scm				\
   guix/cve.scm					\
   guix/workers.scm				\
+  guix/least-authority.scm			\
   guix/ipfs.scm					\
   guix/build-system.scm				\
   guix/build-system/android-ndk.scm		\
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index d52e53eb78..f4caefce3c 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -31,7 +31,8 @@ (define-module (gnu build shepherd)
                                  exec-command
                                  %precious-signals)
   #:autoload (shepherd system) (unblock-signals)
-  #:export (make-forkexec-constructor/container
+  #:export (default-mounts
+            make-forkexec-constructor/container
             fork+exec-command/container))
 
 ;;; Commentary:
diff --git a/guix/least-authority.scm b/guix/least-authority.scm
new file mode 100644
index 0000000000..d871816fca
--- /dev/null
+++ b/guix/least-authority.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix least-authority)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module ((guix store) #:select (%store-prefix))
+  #:autoload   (gnu build linux-container) (%namespaces)
+  #:autoload   (gnu system file-systems) (file-system-mapping
+                                          file-system-mapping-source
+                                          spec->file-system
+                                          file-system->spec
+                                          file-system-mapping->bind-mount)
+  #:export (least-authority-wrapper))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to execute programs with the least authority
+;;; necessary, using Linux namespaces.
+;;;
+;;; Code:
+
+(define %precious-variables
+  ;; Environment variables preserved by the wrapper by default.
+  '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER"))
+
+(define* (least-authority-wrapper program
+                                  #:key (name "pola-wrapper")
+                                  (guest-uid 1000)
+                                  (guest-gid 1000)
+                                  (mappings '())
+                                  (namespaces %namespaces)
+                                  (directory "/")
+                                  (preserved-environment-variables
+                                   %precious-variables))
+  "Return a wrapper of PROGRAM that executes it with the least authority.
+
+PROGRAM is executed in separate namespaces according to NAMESPACES, a list of
+symbols; it turns with GUEST-UID and GUEST-GID.  MAPPINGS is a list of
+<file-system-mapping> records indicating directories mirrored inside the
+execution environment of PROGRAM.  DIRECTORY is the working directory of the
+wrapped process.  Each environment listed in PRESERVED-ENVIRONMENT-VARIABLES
+is preserved; other environment variables are erased."
+  (define code
+    (with-imported-modules (source-module-closure
+                            '((gnu system file-systems)
+                              (gnu build shepherd)
+                              (gnu build linux-container)))
+      #~(begin
+          (use-modules (gnu system file-systems)
+                       (gnu build linux-container)
+                       ((gnu build shepherd) #:select (default-mounts))
+                       (srfi srfi-1))
+
+          (define variables
+            (filter-map (lambda (variable)
+                          (let ((value (getenv variable)))
+                            (and value
+                                 (string-append variable "=" value))))
+                        '#$preserved-environment-variables))
+
+          (define (read-file file)
+            (call-with-input-file file read))
+
+          (define references
+            (delete-duplicates
+             (append-map read-file
+                         '#$(map references-file
+                                 (cons program
+                                       (map file-system-mapping-source
+                                            mappings))))))
+
+          (define (store? file-system)
+            (string=? (file-system-mount-point file-system)
+                      #$(%store-prefix)))
+
+          (define mounts
+            (append (map (lambda (item)
+                           (file-system-mapping->bind-mount
+                            (file-system-mapping (source item)
+                                                 (target item))))
+                         references)
+                    (remove store?
+                            (default-mounts
+                              #:namespaces '#$namespaces))
+                    (map spec->file-system
+                         '#$(map (compose file-system->spec
+                                          file-system-mapping->bind-mount)
+                                 mappings))))
+
+          (define (reify-exit-status status)
+            (cond ((status:exit-val status) => exit)
+                  ((or (status:term-sig status)
+                       (status:stop-sig status))
+                   => (lambda (signal)
+                        (format (current-error-port)
+                                "~a terminated with signal ~a~%"
+                                #$program signal)
+                        (exit (+ 128 signal))))))
+
+          ;; Note: 'call-with-container' creates a sub-process that this one
+          ;; waits for.  This might seem suboptimal but unshare(2) isn't
+          ;; really applicable: the process would still run in the same PID
+          ;; namespace.
+
+          (reify-exit-status
+           (call-with-container mounts
+             (lambda ()
+               (chdir #$directory)
+               (environ variables)
+               (apply execl #$program #$program (cdr (command-line))))
+
+             ;; Don't assume PROGRAM can behave as an init process.
+             #:child-is-pid1? #f
+
+             #:guest-uid #$guest-uid
+             #:guest-gid #$guest-gid
+             #:namespaces '#$namespaces)))))
+
+  (program-file name code))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 07/15] services: dicod: Rewrite using 'least-authority-wrapper'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-8-ludo@gnu.org
* gnu/services/dict.scm (dicod-shepherd-service): Rewrite using
'least-authority-wrapper' plus 'make-forkexec-constructor' instead of
'make-forkexec-constructor/container'.
---
gnu/services/dict.scm | 51 ++++++++++++++++++++++++-------------------
1 file changed, 29 insertions(+), 22 deletions(-)

Toggle diff (83 lines)
diff --git a/gnu/services/dict.scm b/gnu/services/dict.scm
index a97ad8f608..62b21f8d53 100644
--- a/gnu/services/dict.scm
+++ b/gnu/services/dict.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Sou Bunnbu <iyzsong@gmail.com>
-;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -22,12 +22,15 @@ (define-module (gnu services dict)
   #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix least-authority)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system shadow)
   #:use-module ((gnu packages admin) #:select (shadow))
   #:use-module (gnu packages dico)
   #:use-module (gnu packages dictionaries)
+  #:autoload   (gnu build linux-container) (%namespaces)
+  #:autoload   (gnu system file-systems) (file-system-mapping)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -142,27 +145,31 @@ (define %dicod-activation
         (chown rundir (passwd:uid user) (passwd:gid user)))))
 
 (define (dicod-shepherd-service config)
-  (let ((dicod      (file-append (dicod-configuration-dico config)
-                                 "/bin/dicod"))
-        (dicod.conf (dicod-configuration-file config)))
-    (with-imported-modules (source-module-closure
-                            '((gnu build shepherd)
-                              (gnu system file-systems)))
-      (list (shepherd-service
-             (provision '(dicod))
-             (requirement '(user-processes))
-             (documentation "Run the dicod daemon.")
-             (modules '((gnu build shepherd)
-                        (gnu system file-systems)))
-             (start #~(make-forkexec-constructor/container
-                       (list #$dicod "--foreground"
-                             (string-append "--config=" #$dicod.conf))
-                       #:user "dicod" #:group "dicod"
-                       #:mappings (list (file-system-mapping
-                                         (source "/var/run/dicod")
-                                         (target source)
-                                         (writable? #t)))))
-             (stop #~(make-kill-destructor)))))))
+  (let* ((dicod.conf (dicod-configuration-file config))
+         (dicod      (least-authority-wrapper
+                      (file-append (dicod-configuration-dico config)
+                                   "/bin/dicod")
+                      #:name "dicod"
+                      #:mappings (list (file-system-mapping
+                                        (source "/var/run/dicod")
+                                        (target source)
+                                        (writable? #t))
+                                       (file-system-mapping
+                                        (source "/dev/log")
+                                        (target source))
+                                       (file-system-mapping
+                                        (source dicod.conf)
+                                        (target source)))
+                      #:namespaces (delq 'net %namespaces))))
+    (list (shepherd-service
+           (provision '(dicod))
+           (requirement '(user-processes))
+           (documentation "Run the dicod daemon.")
+           (start #~(make-forkexec-constructor
+                     (list #$dicod "--foreground"
+                           (string-append "--config=" #$dicod.conf))
+                     #:user "dicod" #:group "dicod"))
+           (stop #~(make-kill-destructor))))))
 
 (define dicod-service-type
   (service-type
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 13/15] services: wesnothd: Use 'least-authority-wrapper'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-14-ludo@gnu.org
* gnu/services/games.scm (wesnothd-shepherd-service): Use
'least-authority-wrapper' instead of
'make-forkexec-constructor/container'.
---
gnu/services/games.scm | 25 +++++++++++++------------
1 file changed, 13 insertions(+), 12 deletions(-)

Toggle diff (49 lines)
diff --git a/gnu/services/games.scm b/gnu/services/games.scm
index dc0bfbe9dc..6c2af44b49 100644
--- a/gnu/services/games.scm
+++ b/gnu/services/games.scm
@@ -23,6 +23,9 @@ (define-module (gnu services games)
   #:use-module (gnu packages admin)
   #:use-module (gnu packages games)
   #:use-module (gnu system shadow)
+  #:use-module ((gnu system file-systems) #:select (file-system-mapping))
+  #:use-module (gnu build linux-container)
+  #:autoload   (guix least-authority) (least-authority-wrapper)
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix records)
@@ -57,22 +60,20 @@ (define %wesnothd-accounts
 (define wesnothd-shepherd-service
   (match-lambda
     (($ <wesnothd-configuration> package port)
-     (with-imported-modules (source-module-closure
-                             '((gnu build shepherd)
-                               (gnu system file-systems)))
+     (let ((wesnothd (least-authority-wrapper
+                      (file-append package "/bin/wesnothd")
+                      #:name "wesnothd"
+                      #:mappings (list (file-system-mapping
+                                        (source "/var/run/wesnothd")
+                                        (target source)
+                                        (writable? #t)))
+                      #:namespaces (delq 'net %namespaces))))
        (shepherd-service
         (documentation "The Battle for Wesnoth server")
         (provision '(wesnoth-daemon))
         (requirement '(networking))
-        (modules '((gnu build shepherd)
-                   (gnu system file-systems)))
-        (start #~(make-forkexec-constructor/container
-                  (list #$(file-append package "/bin/wesnothd")
-                        "-p" #$(number->string port))
-                  #:mappings (list (file-system-mapping
-                                    (source "/var/run/wesnothd")
-                                    (target source)
-                                    (writable? #t)))
+        (start #~(make-forkexec-constructor
+                  (list #$wesnothd "-p" #$(number->string port))
                   #:user "wesnothd" #:group "wesnothd"))
         (stop #~(make-kill-destructor)))))))
 
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 09/15] services: bitlbee: Use 'make-inetd-constructor'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-10-ludo@gnu.org
* gnu/services/messaging.scm (bitlbee-shepherd-service): Add call to
'least-authority-wrapper'. In 'start' method, use
'make-inetd-constructor' when available.
* gnu/tests/messaging.scm (run-bitlbee-test)["valid PID"]: Remove test.
---
gnu/services/messaging.scm | 63 ++++++++++++++++++++++++++++----------
gnu/tests/messaging.scm | 21 +------------
2 files changed, 48 insertions(+), 36 deletions(-)

Toggle diff (140 lines)
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
index 4bceb1d37a..7fdd8cf285 100644
--- a/gnu/services/messaging.scm
+++ b/gnu/services/messaging.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017-2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Pierre-Antoine Rouby <contact@parouby.fr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -28,11 +28,14 @@ (define-module (gnu services messaging)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services configuration)
   #:use-module (gnu system shadow)
+  #:autoload   (gnu build linux-container) (%namespaces)
+  #:use-module ((gnu system file-systems) #:select (file-system-mapping))
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix deprecation)
+  #:use-module (guix least-authority)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
@@ -821,7 +824,18 @@ (define bitlbee-shepherd-service
   DaemonInterface = " interface "
   DaemonPort = " (number->string port) "
   PluginDir = " plugins "/lib/bitlbee
-" extra-settings)))
+" extra-settings))
+            (bitlbee* (least-authority-wrapper
+                       (file-append bitlbee "/sbin/bitlbee")
+                       #:name "bitlbee"
+                       #:mappings (list (file-system-mapping
+                                         (source "/var/lib/bitlbee")
+                                         (target source)
+                                         (writable? #t))
+                                        (file-system-mapping
+                                         (source conf)
+                                         (target conf)))
+                       #:namespaces (delq 'net %namespaces))))
 
        (with-imported-modules (source-module-closure
                                '((gnu build shepherd)
@@ -836,20 +850,37 @@ (define bitlbee-shepherd-service
 
                 (modules '((gnu build shepherd)
                            (gnu system file-systems)))
-                (start #~(make-forkexec-constructor/container
-                          (list #$(file-append bitlbee "/sbin/bitlbee")
-                                "-n" "-F" "-u" "bitlbee" "-c" #$conf)
-
-                          ;; Allow 'bitlbee-purple' to use libpurple plugins.
-                          #:environment-variables
-                          (list (string-append "PURPLE_PLUGIN_PATH="
-                                               #$plugins "/lib/purple-2"))
-
-                          #:pid-file "/var/run/bitlbee.pid"
-                          #:mappings (list (file-system-mapping
-                                            (source "/var/lib/bitlbee")
-                                            (target source)
-                                            (writable? #t)))))
+                (start #~(if (defined? 'make-inetd-constructor)
+
+                             (make-inetd-constructor
+                              (list #$bitlbee* "-I"
+                                    "-u" "bitlbee" "-c" #$conf)
+                              (addrinfo:addr
+                               (car (getaddrinfo #$interface
+                                                 #$(number->string port)
+                                                 (logior AI_NUMERICHOST
+                                                         AI_NUMERICSERV))))
+                              #:service-name-stem "bitlbee"
+
+                              ;; Allow 'bitlbee-purple' to use libpurple plugins.
+                              #:environment-variables
+                              (list (string-append "PURPLE_PLUGIN_PATH="
+                                                   #$plugins "/lib/purple-2")))
+
+                             (make-forkexec-constructor/container
+                              (list #$(file-append bitlbee "/sbin/bitlbee")
+                                    "-n" "-F" "-u" "bitlbee" "-c" #$conf)
+
+                              ;; Allow 'bitlbee-purple' to use libpurple plugins.
+                              #:environment-variables
+                              (list (string-append "PURPLE_PLUGIN_PATH="
+                                                   #$plugins "/lib/purple-2"))
+
+                              #:pid-file "/var/run/bitlbee.pid"
+                              #:mappings (list (file-system-mapping
+                                                (source "/var/lib/bitlbee")
+                                                (target source)
+                                                (writable? #t))))))
                 (stop  #~(make-kill-destructor)))))))))
 
 (define %bitlbee-accounts
diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm
index 202a1c2f73..1e26c0ddea 100644
--- a/gnu/tests/messaging.scm
+++ b/gnu/tests/messaging.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
-;;; Copyright © 2017, 2018, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017-2018, 2021-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -198,25 +198,6 @@ (define marionette
                 (start-service 'bitlbee))
              marionette))
 
-          (test-equal "valid PID"
-            #$(file-append bitlbee "/sbin/bitlbee")
-            (marionette-eval
-             '(begin
-                (use-modules (srfi srfi-1)
-                             (gnu services herd))
-
-                (let ((bitlbee
-                       (find (lambda (service)
-                               (equal? '(bitlbee)
-                                       (live-service-provision service)))
-                             (current-services))))
-                  (and (pk 'bitlbee-service bitlbee)
-                       (let ((pid (live-service-running bitlbee)))
-                         (readlink (string-append "/proc/"
-                                                  (number->string pid)
-                                                  "/exe"))))))
-             marionette))
-
           (test-assert "connect"
             (let* ((address (make-socket-address AF_INET INADDR_LOOPBACK
                                                  6667))
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 11/15] services: ipfs: Use 'least-authority-wrapper'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-12-ludo@gnu.org
* gnu/services/networking.scm (ipfs-binary): Call
'least-authority-wrapper'.
(%ipfs-home-mapping): Remove surrounding gexp.
(ipfs-shepherd-service)[exec-command]: New procedure.
[ipfs-config-command, set-config!-gexp, shepherd&co]
[container-gexp, container-script]: Remove.
[inner-gexp]: Use 'exec-command'.
---
gnu/services/networking.scm | 123 +++++++++++++++++-------------------
1 file changed, 58 insertions(+), 65 deletions(-)

Toggle diff (181 lines)
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index b302be5aaf..4708ade0ca 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2016, 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2016 John Darrington <jmd@gnu.org>
@@ -43,6 +43,7 @@ (define-module (gnu services networking)
   #:use-module (gnu services dbus)
   #:use-module (gnu system shadow)
   #:use-module (gnu system pam)
+  #:use-module ((gnu system file-systems) #:select (file-system-mapping))
   #:use-module (gnu packages admin)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
@@ -59,6 +60,7 @@ (define-module (gnu services networking)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages ipfs)
   #:use-module (gnu build linux-container)
+  #:autoload   (guix least-authority) (least-authority-wrapper)
   #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix modules)
@@ -2018,13 +2020,20 @@ (define %ipfs-accounts
          (system? #t))))
 
 (define (ipfs-binary config)
-  (file-append (ipfs-configuration-package config) "/bin/ipfs"))
+  (define command
+    (file-append (ipfs-configuration-package config) "/bin/ipfs"))
+
+  (least-authority-wrapper
+   command
+   #:name "ipfs"
+   #:mappings (list %ipfs-home-mapping)
+   #:namespaces (delq 'net %namespaces)))
 
 (define %ipfs-home-mapping
-  #~(file-system-mapping
-     (source #$%ipfs-home)
-     (target #$%ipfs-home)
-     (writable? #t)))
+  (file-system-mapping
+   (source %ipfs-home)
+   (target %ipfs-home)
+   (writable? #t)))
 
 (define %ipfs-environment
   #~(list #$(string-append "HOME=" %ipfs-home)))
@@ -2033,82 +2042,66 @@ (define (ipfs-shepherd-service config)
   "Return a <shepherd-service> for IPFS with CONFIG."
   (define ipfs-daemon-command
     #~(list #$(ipfs-binary config) "daemon"))
-  (list
-   (with-imported-modules (source-module-closure
-                           '((gnu build shepherd)
-                             (gnu system file-systems)))
-     (shepherd-service
-      (provision '(ipfs))
-      ;; While IPFS is most useful when the machine is connected
-      ;; to the network, only loopback is required for starting
-      ;; the service.
-      (requirement '(loopback))
-      (documentation "Connect to the IPFS network")
-      (modules '((gnu build shepherd)
-                 (gnu system file-systems)))
-      (start #~(make-forkexec-constructor/container
-                #$ipfs-daemon-command
-                #:namespaces '#$(fold delq %namespaces '(user net))
-                #:mappings (list #$%ipfs-home-mapping)
-                #:log-file "/var/log/ipfs.log"
-                #:user "ipfs"
-                #:group "ipfs"
-                #:environment-variables #$%ipfs-environment))
-      (stop #~(make-kill-destructor))))))
+
+  (list (shepherd-service
+         (provision '(ipfs))
+         ;; While IPFS is most useful when the machine is connected
+         ;; to the network, only loopback is required for starting
+         ;; the service.
+         (requirement '(loopback))
+         (documentation "Connect to the IPFS network")
+         (start #~(make-forkexec-constructor
+                   #$ipfs-daemon-command
+                   #:log-file "/var/log/ipfs.log"
+                   #:user "ipfs" #:group "ipfs"
+                   #:environment-variables #$%ipfs-environment))
+         (stop #~(make-kill-destructor)))))
 
 (define (%ipfs-activation config)
   "Return an activation gexp for IPFS with CONFIG"
-  (define (ipfs-config-command setting value)
-    #~(#$(ipfs-binary config) "config" #$setting #$value))
-  (define (set-config!-gexp setting value)
-    #~(system* #$@(ipfs-config-command setting value)))
+  (define (exec-command . args)
+    ;; Exec the given ifps command with the right authority.
+    #~(let ((pid (primitive-fork)))
+        (if (zero? pid)
+            (dynamic-wind
+              (const #t)
+              (lambda ()
+                ;; Run ipfs init and ipfs config from a container,
+                ;; in case the IPFS daemon was compromised at some point
+                ;; and ~/.ipfs is now a symlink to somewhere outside
+                ;; %ipfs-home.
+                (let ((pw (getpwnam "ipfs")))
+                  (setgroups '#())
+                  (setgid (passwd:gid pw))
+                  (setuid (passwd:uid pw))
+                  (environ #$%ipfs-environment)
+                  (execl #$(ipfs-binary config) #$@args)))
+              (lambda ()
+                (primitive-exit 127)))
+            (waitpid pid))))
+
   (define settings
     `(("Addresses.API" ,(ipfs-configuration-api config))
       ("Addresses.Gateway" ,(ipfs-configuration-gateway config))))
+
   (define inner-gexp
     #~(begin
         (umask #o077)
         ;; Create $HOME/.ipfs structure
-        (system* #$(ipfs-binary config) "init")
+        #$(exec-command "ipfs" "init")
         ;; Apply settings
-        #$@(map (cute apply set-config!-gexp <>) settings)))
+        #$@(map (match-lambda
+                  ((setting value)
+                   (exec-command "ipfs" "config" setting value)))
+                settings)))
+
   (define inner-script
     (program-file "ipfs-activation-inner" inner-gexp))
 
-  (define shepherd&co
-    ;; 'make-forkexec-constructor/container' needs version 0.9 for
-    ;; #:supplementary-groups.
-    (cons shepherd-0.9
-          (list (lookup-package-input shepherd-0.9 "guile-fibers"))))
-
-  ;; Run ipfs init and ipfs config from a container,
-  ;; in case the IPFS daemon was compromised at some point
-  ;; and ~/.ipfs is now a symlink to somewhere outside
-  ;; %ipfs-home.
-  (define container-gexp
-    (with-extensions shepherd&co
-      (with-imported-modules (source-module-closure
-                              '((gnu build shepherd)
-                                (gnu system file-systems)))
-        #~(begin
-            (use-modules (gnu build shepherd)
-                         (gnu system file-systems))
-            (let* ((constructor
-                    (make-forkexec-constructor/container
-                     (list #$inner-script)
-                     #:namespaces '#$(fold delq %namespaces '(user))
-                     #:mappings (list #$%ipfs-home-mapping)
-                     #:user "ipfs"
-                     #:group "ipfs"
-                     #:environment-variables #$%ipfs-environment))
-                   (pid (constructor)))
-              (waitpid pid))))))
   ;; The activation may happen from the initrd, which uses
   ;; a statically-linked guile, while the guix container
   ;; procedures require a working dynamic-link.
-  (define container-script
-    (program-file "ipfs-activation-container" container-gexp))
-  #~(system* #$container-script))
+  #~(system* #$inner-script))
 
 (define ipfs-service-type
   (service-type
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 14/15] services: quassel: Use 'least-authority-wrapper'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-15-ludo@gnu.org
* gnu/services/messaging.scm (quassel-shepherd-service): Use
'least-authority-wrapper' instead of
'make-forkexec-constructor/container'.
---
gnu/services/messaging.scm | 42 ++++++++++++++++++++------------------
1 file changed, 22 insertions(+), 20 deletions(-)

Toggle diff (58 lines)
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
index 7fdd8cf285..05bf6e784b 100644
--- a/gnu/services/messaging.scm
+++ b/gnu/services/messaging.scm
@@ -939,29 +939,31 @@ (define-record-type* <quassel-configuration>
 (define quassel-shepherd-service
   (match-lambda
     (($ <quassel-configuration> quassel interface port loglevel)
-     (with-imported-modules (source-module-closure
-                              '((gnu build shepherd)
-                                (gnu system file-systems)))
+     (let ((quassel (least-authority-wrapper
+                     (file-append quassel "/bin/quasselcore")
+                     #:name "quasselcore"
+                     #:mappings (list (file-system-mapping
+                                       (source "/var/lib/quassel")
+                                       (target source)
+                                       (writable? #t))
+                                      (file-system-mapping
+                                       (source "/var/log/quassel")
+                                       (target source)
+                                       (writable? #t)))
+                     ;; XXX: The daemon needs to live in the main user
+                     ;; namespace, as root, so it can access /var/lib/quassel
+                     ;; owned by "quasselcore".
+                     #:namespaces (fold delq %namespaces '(net user)))))
        (list (shepherd-service
                (provision '(quassel))
                (requirement '(user-processes networking))
-               (modules '((gnu build shepherd)
-                          (gnu system file-systems)))
-               (start #~(make-forkexec-constructor/container
-                          (list #$(file-append quassel "/bin/quasselcore")
-                                "--configdir=/var/lib/quassel"
-                                "--logfile=/var/log/quassel/core.log"
-                                (string-append "--loglevel=" #$loglevel)
-                                (string-append "--port=" (number->string #$port))
-                                (string-append "--listen=" #$interface))
-                          #:mappings (list (file-system-mapping
-                                             (source "/var/lib/quassel")
-                                             (target source)
-                                             (writable? #t))
-                                           (file-system-mapping
-                                             (source "/var/log/quassel")
-                                             (target source)
-                                             (writable? #t)))))
+               (start #~(make-forkexec-constructor
+                         (list #$quassel
+                               "--configdir=/var/lib/quassel"
+                               "--logfile=/var/log/quassel/core.log"
+                               (string-append "--loglevel=" #$loglevel)
+                               (string-append "--port=" (number->string #$port))
+                               (string-append "--listen=" #$interface))))
                (stop  #~(make-kill-destructor))))))))
 
 (define %quassel-account
-- 
2.35.1
L
L
Ludovic Courtès wrote on 27 Apr 18:56 +0200
[PATCH v2 15/15] services: opendht: Use 'least-authority-wrapper'.
(address . 54997@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
20220427165635.8015-16-ludo@gnu.org
* gnu/services/networking.scm (opendht-configuration->command-line-arguments):
Use 'least-authority-wrapper'.
(opendht-shepherd-service): Use 'make-forkexec-constructor'.
---
gnu/services/networking.scm | 40 ++++++++++++++++++++-----------------
1 file changed, 22 insertions(+), 18 deletions(-)

Toggle diff (60 lines)
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 4708ade0ca..5873070bdd 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -796,7 +796,19 @@ (define (opendht-configuration->command-line-arguments config)
   (match-record config <opendht-configuration>
     (opendht bootstrap-host enable-logging? port debug? peer-discovery?
              proxy-server-port proxy-server-port-tls)
-    (let ((dhtnode #~(string-append #$opendht:tools "/bin/dhtnode")))
+    (let ((dhtnode (least-authority-wrapper
+                    ;; XXX: Work around lack of support for multiple outputs
+                    ;; in 'file-append'.
+                    (computed-file "dhtnode"
+                                   #~(symlink
+                                      (string-append #$opendht:tools
+                                                     "/bin/dhtnode")
+                                      #$output))
+                    #:name "dhtnode"
+                    #:mappings (list (file-system-mapping
+                                      (source "/dev/log") ;for syslog
+                                      (target source)))
+                    #:namespaces (delq 'net %namespaces))))
       `(,dhtnode
         "--service"                     ;non-forking mode
         ,@(if (string? bootstrap-host)
@@ -822,23 +834,15 @@ (define (opendht-configuration->command-line-arguments config)
 
 (define (opendht-shepherd-service config)
   "Return a <shepherd-service> running OpenDHT."
-  (with-imported-modules (source-module-closure
-                          '((gnu build shepherd)
-                            (gnu system file-systems)))
-    (shepherd-service
-     (documentation "Run an OpenDHT node.")
-     (provision '(opendht dhtnode dhtproxy))
-     (requirement '(networking syslogd))
-     (modules '((gnu build shepherd)
-                (gnu system file-systems)))
-     (start #~(make-forkexec-constructor/container
-               (list #$@(opendht-configuration->command-line-arguments config))
-               #:mappings (list (file-system-mapping
-                                 (source "/dev/log") ;for syslog
-                                 (target source)))
-               #:user "opendht"
-               #:group "opendht"))
-     (stop #~(make-kill-destructor)))))
+  (shepherd-service
+   (documentation "Run an OpenDHT node.")
+   (provision '(opendht dhtnode dhtproxy))
+   (requirement '(networking syslogd))
+   (start #~(make-forkexec-constructor
+             (list #$@(opendht-configuration->command-line-arguments config))
+             #:user "opendht"
+             #:group "opendht"))
+   (stop #~(make-kill-destructor))))
 
 (define opendht-service-type
   (service-type
-- 
2.35.1
L
L
Ludovic Courtès wrote on 28 Apr 00:01 +0200
Re: bug#54997: [PATCH 00/12] Add "least authority" program wrapper
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 54997@debbugs.gnu.org)
878rrqgp7x.fsf@gnu.org
Hi,

Maxime Devos <maximedevos@telenet.be> skribis:

Toggle quote (4 lines)
> Many of these are supported by 'least-authority-wrapper' but these POLA
> wrappers require creating an additional process which seems a bit
> unoptimal to me (memory- and latency-wise).

Yeah, that’s why I initially looked at unshare(2), just to find out that
we can’t quite do the same as with clone(2)—in particular we cannot
escape the current PID namespace.

(There were also complications, such as the fact that you can only
unshare(2) a single-threaded process, meaning that Guile had to be
started with GC_MARKERS=1. For posterity, part of the patch I had is
attached below.)

Toggle quote (5 lines)
> Also, having to do fork, waitpid and primitive-fork seems rather low-
> level to me, so I prefer moving this code into somewhere like (gnu
> build SOMEWHERE) or to keep the old make-forkexec-constructor/container
> code.

‘primitive-fork’ and ‘waitpid’ calls are in (gnu build linux-container)
right now so I guess we’re fine?

The goal though is to replace uses of
‘make-forkexec-constructor/container’ with uses of
‘least-authority-wrapper’, as done in this patch series.

Ludo’.
Toggle diff (213 lines)
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index bdeca2cdb9..308c0bb325 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +21,7 @@ (define-module (gnu build linux-container)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-98)
   #:use-module (guix build utils)
   #:use-module (guix build syscalls)
@@ -33,7 +34,8 @@ (define-module (gnu build linux-container)
             run-container
             call-with-container
             container-excursion
-            container-excursion*))
+            container-excursion*
+            self-sever))
 
 (define (user-namespace-supported?)
   "Return #t if user namespaces are supported on this system."
@@ -174,50 +176,53 @@ (define* (mount* source target type #:optional (flags 0) options
     (chmod "/" #o755)))
 
 (define* (initialize-user-namespace pid host-uids
-                                    #:key (guest-uid 0) (guest-gid 0))
+                                    #:key (guest-uid 0) (guest-gid 0)
+                                    (uid (getuid)) (gid (getgid)))
   "Configure the user namespace for PID.  HOST-UIDS specifies the number of
 host user identifiers to map into the user namespace.  GUEST-UID and GUEST-GID
 specify the first UID (respectively GID) that host UIDs (respectively GIDs)
 map to in the namespace."
   (define proc-dir
-    (string-append "/proc/" (number->string pid)))
+    (string-append "/proc/"
+                   (match pid
+                     ('self "self")
+                     (_ (number->string pid)))))
 
   (define (scope file)
     (string-append proc-dir file))
 
-  (let ((uid (getuid))
-        (gid (getgid)))
-
-    ;; Only root can write to the gid map without first disabling the
-    ;; setgroups syscall.
-    (unless (and (zero? uid) (zero? gid))
-      (call-with-output-file (scope "/setgroups")
-        (lambda (port)
-          (display "deny" port))))
-
-    ;; Map the user/group that created the container to the root user
-    ;; within the container.
-    (call-with-output-file (scope "/uid_map")
+  ;; Only root can write to the gid map without first disabling the
+  ;; setgroups syscall.
+  (unless (and (zero? uid) (zero? gid))
+    (call-with-output-file (scope "/setgroups")
       (lambda (port)
-        (format port "~d ~d ~d" guest-uid uid host-uids)))
-    (call-with-output-file (scope "/gid_map")
-      (lambda (port)
-        (format port "~d ~d ~d" guest-gid gid host-uids)))))
+        (display "deny" port))))
+
+  ;; Map the user/group that created the container to the root user
+  ;; within the container.
+  (call-with-output-file (scope "/uid_map")
+    (lambda (port)
+      (format port "~d ~d ~d" guest-uid uid host-uids)))
+  (call-with-output-file (scope "/gid_map")
+    (lambda (port)
+      (format port "~d ~d ~d" guest-gid gid host-uids))))
 
 (define (namespaces->bit-mask namespaces)
   "Return the number suitable for the 'flags' argument of 'clone' that
 corresponds to the symbols in NAMESPACES."
   ;; Use the same flags as fork(3) in addition to the namespace flags.
-  (apply logior SIGCHLD
-         (map (match-lambda
-               ('cgroup  CLONE_NEWCGROUP)
-               ('mnt  CLONE_NEWNS)
-               ('uts  CLONE_NEWUTS)
-               ('ipc  CLONE_NEWIPC)
-               ('user CLONE_NEWUSER)
-               ('pid  CLONE_NEWPID)
-               ('net  CLONE_NEWNET))
-              namespaces)))
+  (fold (lambda (namespace flags)
+          (logior flags
+                  (match namespace
+                    ('cgroup  CLONE_NEWCGROUP)
+                    ('mnt  CLONE_NEWNS)
+                    ('uts  CLONE_NEWUTS)
+                    ('ipc  CLONE_NEWIPC)
+                    ('user CLONE_NEWUSER)
+                    ('pid  CLONE_NEWPID)
+                    ('net  CLONE_NEWNET))))
+        0
+        namespaces))
 
 (define* (run-container root mounts namespaces host-uids thunk
                         #:key (guest-uid 0) (guest-gid 0))
@@ -236,7 +241,7 @@ (define* (run-container root mounts namespaces host-uids thunk
   (match (socketpair PF_UNIX SOCK_STREAM 0)
     ((child . parent)
      (let ((flags (namespaces->bit-mask namespaces)))
-       (match (clone flags)
+       (match (clone (logior SIGCHLD flags))
          (0
           (call-with-clean-exit
            (lambda ()
@@ -392,3 +397,23 @@ (define (container-excursion* pid thunk)
         (close-port out)
         (close-port in)
         #f)))))
+
+(define* (self-sever mounts
+                     #:key (namespaces %namespaces) (host-uids 1)
+                     (guest-uid 0) (guest-gid 0))
+  (let ((uid (getuid))
+        (gid (getgid)))
+    (unshare (namespaces->bit-mask namespaces))
+
+    (initialize-user-namespace 'self host-uids
+                               #:uid uid #:gid gid
+                               #:guest-uid uid
+                               #:guest-gid guest-gid)
+
+    (when (memq 'mnt namespaces)
+      ;; (mount "none" "/" #f (logior MS_REC MS_PRIVATE))
+      (call-with-temporary-directory
+       (lambda (root)
+         (mount-file-systems root mounts
+                             #:mount-/proc? (memq 'pid namespaces)
+                             #:mount-/sys?  (memq 'net namespaces)))))))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index a7401fd73f..5ee6bd1229 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -49,6 +49,11 @@ (define-module (guix build syscalls)
             MS_RELATIME
             MS_BIND
             MS_MOVE
+            MS_REC
+            MS_SILENT
+            MS_POSIXACL
+            MS_UNBINDABLE
+            MS_PRIVATE
             MS_LAZYTIME
             MNT_FORCE
             MNT_DETACH
@@ -140,6 +145,7 @@ (define-module (guix build syscalls)
             CLONE_NEWPID
             CLONE_NEWNET
             clone
+            unshare
             setns
 
             PF_PACKET
@@ -537,6 +543,11 @@ (define MS_REMOUNT           32)
 (define MS_NOATIME         1024)
 (define MS_BIND            4096)
 (define MS_MOVE            8192)
+(define MS_REC            16384)
+(define MS_SILENT         32768)
+(define MS_POSIXACL       65536)
+(define MS_UNBINDABLE    131072)
+(define MS_PRIVATE       262144)
 (define MS_RELATIME     2097152)
 (define MS_STRICTATIME 16777216)
 (define MS_LAZYTIME    33554432)
@@ -1101,6 +1112,23 @@ (define clone
                    (list err))
             ret)))))
 
+(define unshare
+  (let ((proc (syscall->procedure int "unshare" (list int))))
+    (lambda (flags)
+      "Disassociate the current process from parts of its execution context
+according to FLAGS, which must be a logical or of CLONE_NEW* constants.
+
+Note that CLONE_NEWUSER requires that the calling process be single-threaded,
+which is possible if and only if libgc is running a single marker thread; this
+can be achieved by setting the GC_MARKERS environment variable to 1.  If the
+calling process is multi-threaded, this throws to 'system-error' with EINVAL."
+      (let-values (((ret err)
+                    (without-automatic-finalization (proc flags))))
+        (unless (zero? ret)
+          (throw 'system-error "unshare" "~a: ~A"
+                 (list flags (strerror err))
+                 err))))))
+
 (define setns
   ;; Some systems may be using an old (pre-2.14) version of glibc where there
   ;; is no 'setns' function available.
M
M
Maxime Devos wrote on 28 Apr 13:29 +0200
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 54997@debbugs.gnu.org)
31ff48d9240cf1ab53405c097bbe7148be3ed3bf.camel@telenet.be
Ludovic Courtès schreef op do 28-04-2022 om 00:01 [+0200]:
Toggle quote (9 lines)
> > Also, having to do fork, waitpid and primitive-fork seems rather
> > low-level to me, so I prefer moving this code into somewhere like
> > (gnu build SOMEWHERE) or to keep the old make-forkexec-
> > constructor/container code.
>
> ‘primitive-fork’ and ‘waitpid’ calls are in (gnu build linux-
> container)
> right now so I guess we’re fine?

Their use in (gnu build linux-container) seems fine to me, but their
use in %ipfs-activation doesn't:

Toggle quote (9 lines)
> + #~(let ((pid (primitive-fork)))
> + (if (zero? pid)
> + (dynamic-wind
> + (const #t)
> + (lambda ()
> + [...] (execl #$(ipfs-binary config) #$@args)))
> + (lambda ()
> + (primitive-exit 127)))

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYmp6oxccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7p1jAP9PfrSueTBAfM/Qw995YPaSr4eN
p4vvPWUCkB9J5IEwhwEApfLuiUtnl+I2rNltmKV4QbvxrUxdXqALl5eTqdzHDw8=
=BlYP
-----END PGP SIGNATURE-----


L
L
Ludovic Courtès wrote on 28 Apr 21:25 +0200
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 54997@debbugs.gnu.org)
87pml1au3m.fsf@gnu.org
Hi Maxime,

Maxime Devos <maximedevos@telenet.be> skribis:

Toggle quote (22 lines)
> Ludovic Courtès schreef op do 28-04-2022 om 00:01 [+0200]:
>> > Also, having to do fork, waitpid and primitive-fork seems rather
>> > low-level to me, so I prefer moving this code into somewhere like
>> > (gnu build SOMEWHERE) or to keep the old make-forkexec-
>> > constructor/container code.
>>
>> ‘primitive-fork’ and ‘waitpid’ calls are in (gnu build linux-
>> container)
>> right now so I guess we’re fine?
>
> Their use in (gnu build linux-container) seems fine to me, but their
> use in %ipfs-activation doesn't:
>
>> + #~(let ((pid (primitive-fork)))
>> + (if (zero? pid)
>> + (dynamic-wind
>> + (const #t)
>> + (lambda ()
>> + [...] (execl #$(ipfs-binary config) #$@args)))
>> + (lambda ()
>> + (primitive-exit 127)))

Oh I see, and I agree.

Now, to be fair, this patch deletes more lines than it adds:

Toggle quote (11 lines)
> * gnu/services/networking.scm (ipfs-binary): Call
> 'least-authority-wrapper'.
> (%ipfs-home-mapping): Remove surrounding gexp.
> (ipfs-shepherd-service)[exec-command]: New procedure.
> [ipfs-config-command, set-config!-gexp, shepherd&co]
> [container-gexp, container-script]: Remove.
> [inner-gexp]: Use 'exec-command'.
> ---
> gnu/services/networking.scm | 123 +++++++++++++++++-------------------
> 1 file changed, 58 insertions(+), 65 deletions(-)

The previous code abused ‘make-forkexec-constructor/container’ as a way
to spawn processes during activation, which wasn’t great either IMO.

So yes, I agree there’s room for improvement here and that this calls
for some kind of ‘system*’ interface, if the need is common enough.
But! I don’t think this is a blocker for the whole series.

WDYT? :-)

Thanks,
Ludo’.
M
M
Maxime Devos wrote on 28 Apr 21:52 +0200
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 54997@debbugs.gnu.org)
4d8266b45cd2dc5ba0113e086f4b81fc42f27a8a.camel@telenet.be
Ludovic Courtès schreef op do 28-04-2022 om 21:25 [+0200]:
Toggle quote (9 lines)
> The previous code abused ‘make-forkexec-constructor/container’ as a way
> to spawn processes during activation, which wasn’t great either IMO.
>
> So yes, I agree there’s room for improvement here and that this calls
> for some kind of ‘system*’ interface, if the need is common enough.
> But! I don’t think this is a blocker for the whole series.
>
> WDYT?  :-)

Agreed that it's not a blocker, but next I have to write something
similar, I think I'll then propose some kind of variant of system*.
I guess I'm personally more inclined than you to write abstractions
that only have a single use.

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYmrwbhccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7vNfAPwMC5xGqray3cu5M6nKEXnZ30zm
QqpqbGYRNyo8z7gNuwEA6DupSEivwYv6mWBFPFZUFY76IXbE0uqRMSKXL2wxrwc=
=Eg82
-----END PGP SIGNATURE-----


T
T
Thiago Jung Bauermann wrote on 29 Apr 05:43 +0200
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 54997@debbugs.gnu.org)
878rrownqz.fsf@kolabnow.com
Hi Ludo!

Ludovic Courtès <ludo@gnu.org> writes:
Toggle quote (11 lines)
> Thiago Jung Bauermann <bauermann@kolabnow.com> skribis:
>> So to avoid an accumulation of zombie processes and other signal-related
>> problems, I suggest adding a “(init-program ,tini)” parameter to
>> ‘least-authority-wrapper’ and executing ‘program’ as a subprocess of
>> ‘tini’ or whatever was passed as the #:init-program (perhaps #f could
>> mean running ‘program’ directly as PID 1).
>
> Hmm yes. It’s not great that the choice is between ‘unshare’—efficient
> but the process lives in the parent PID namespace—and ‘clone’—but then
> you have to fork twice.

Yeah, the signals part of the Unix design isn't great.

Toggle quote (2 lines)
> But yeah, you’re right. I’ll try what you suggest and send a v2.

Thank you for making these changes! I had a look at v2 and it looks
great.

Toggle quote (15 lines)
>> I mention this because I'm currently dealing with a problem that has
>> exactly this root cause: I'm working on updating the public-inbox
>> package to the latest version, and the testsuite is failing because it
>> tests that lei's daemon process is correctly terminated. But that
>> doesn't work because “guix build” doesn't use a proper init program as
>> PID 1 and thus the daemon process goes to zombie state and the testsuite
>> thinks that it didn't go away. I'm hoping to send a patch to fix that
>> issue.
>
> Now that you mention it, this was discussed before:
>
> https://issues.guix.gnu.org/30948
>
> I think we should do something about it in gnu-build-system.scm.

Nice! Thank you for the link. The discussion there was very informative.
I'll try to implement your idea of adding a new build phase to install
the appropriate signal handlers. Probably even steal your child reaping
code from the v2 patches.

Toggle quote (2 lines)
> Thanks for your feedback!

Thank you for taking it into account!

--
Thanks
Thiago
L
L
Ludovic Courtès wrote on 1 May 22:16 +0200
(address . 54997-done@debbugs.gnu.org)
87pmkx2elg.fsf_-_@gnu.org
Ludovic Courtès <ludo@gnu.org> skribis:

Toggle quote (18 lines)
> gexp: Add 'references-file'.
> file-systems: Avoid load-time warnings when attempting to load (guix
> store).
> linux-container: 'call-with-container' relays SIGTERM and SIGINT.
> linux-container: Ensure signal-handling asyncs get a chance to run.
> linux-container: Add #:child-is-pid1? parameter to
> 'call-with-container'.
> Add (guix least-authority).
> services: dicod: Rewrite using 'least-authority-wrapper'.
> services: dicod: Use 'make-inetd-constructor'.
> services: bitlbee: Use 'make-inetd-constructor'.
> services: ipfs: Adjust for Shepherd 0.9.
> services: ipfs: Use 'least-authority-wrapper'.
> services: wesnothd: Grant write access to /var/run/wesnothd.
> services: wesnothd: Use 'least-authority-wrapper'.
> services: quassel: Use 'least-authority-wrapper'.
> services: opendht: Use 'least-authority-wrapper'.

Pushed as fee06d5aaa71a965ea0bc06c1ff15c138a8bb2c8, thanks again for
reviewing!

Ludo’.
Closed
T
T
Thiago Jung Bauermann wrote on 2 May 06:25 +0200
(name . Ludovic Courtès)(address . ludo@gnu.org)
87bkwgy30f.fsf@kolabnow.com
Ludovic Courtès <ludo@gnu.org> writes:

Toggle quote (23 lines)
> Ludovic Courtès <ludo@gnu.org> skribis:
>
>> gexp: Add 'references-file'.
>> file-systems: Avoid load-time warnings when attempting to load (guix
>> store).
>> linux-container: 'call-with-container' relays SIGTERM and SIGINT.
>> linux-container: Ensure signal-handling asyncs get a chance to run.
>> linux-container: Add #:child-is-pid1? parameter to
>> 'call-with-container'.
>> Add (guix least-authority).
>> services: dicod: Rewrite using 'least-authority-wrapper'.
>> services: dicod: Use 'make-inetd-constructor'.
>> services: bitlbee: Use 'make-inetd-constructor'.
>> services: ipfs: Adjust for Shepherd 0.9.
>> services: ipfs: Use 'least-authority-wrapper'.
>> services: wesnothd: Grant write access to /var/run/wesnothd.
>> services: wesnothd: Use 'least-authority-wrapper'.
>> services: quassel: Use 'least-authority-wrapper'.
>> services: opendht: Use 'least-authority-wrapper'.
>
> Pushed as fee06d5aaa71a965ea0bc06c1ff15c138a8bb2c8, thanks again for
> reviewing!

That's great! Thank you for addressing the PID 1 issue!

--
Thanks
Thiago
Closed
?
Your comment

This issue is archived.

To comment on this conversation send email to 54997@debbugs.gnu.org