[bug#67175] [PATCH 1/9] services: pagekite: Use ‘least-authority-wrapper’.

[bug#67175] [PATCH 1/9] services: pagekite: Use ‘least-authority-wrapper’.

[Ludovic Courtès]

* gnu/services/networking.scm (pagekite-shepherd-service): Define
‘config-file’ and ‘mappings’; define ‘pagekite’ in terms of
‘least-authority-wrapper’.  Remove now-unneeded ‘with-imported-modules’
form and ‘modules’ field.  Use ‘make-forkexec-constructor’ instead of
‘make-forkexec-constructor/container’.

Change-Id: I7c6c6266785f6a0f81a69d85f070779a0d6edd91
---
 gnu/services/networking.scm | 35 ++++++++++++++++++++---------------
 1 file changed, 20 insertions(+), 15 deletions(-)

diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 0508a4282c..d3376f9acb 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -1918,29 +1918,34 @@ (define (pagekite-configuration-file config)
 (define (pagekite-shepherd-service config)
   (match-record config <pagekite-configuration>
     (package kitename kitesecret frontend kites extra-file)
-    (with-imported-modules (source-module-closure
-                            '((gnu build shepherd)
-                              (gnu system file-systems)))
+    (let* ((config-file (pagekite-configuration-file config))
+           (mappings (cons (file-system-mapping
+                            (source config-file)
+                            (target source))
+                           (if extra-file
+                               (list (file-system-mapping
+                                      (source extra-file)
+                                      (target source)))
+                               '())))
+           (pagekite (least-authority-wrapper
+                      (file-append package "/bin/pagekite")
+                      #:name "pagekite"
+                      #:mappings mappings
+                      ;; 'pagekite' changes user IDs to it needs to run in the
+                      ;; global user namespace.
+                      #:namespaces (fold delq %namespaces '(net user)))))
       (shepherd-service
        (documentation "Run the PageKite service.")
        (provision '(pagekite))
        (requirement '(networking))
-       (modules '((gnu build shepherd)
-                  (gnu system file-systems)))
-       (start #~(make-forkexec-constructor/container
-                 (list #$(file-append package "/bin/pagekite")
+       (start #~(make-forkexec-constructor
+                 (list #$pagekite
                        "--clean"
                        "--nullui"
                        "--nocrashreport"
                        "--runas=pagekite:pagekite"
-                       (string-append "--optfile="
-                                      #$(pagekite-configuration-file config)))
-                 #:log-file "/var/log/pagekite.log"
-                 #:mappings #$(if extra-file
-                                  #~(list (file-system-mapping
-                                           (source #$extra-file)
-                                           (target source)))
-                                  #~'())))
+                       (string-append "--optfile=" #$config-file))
+                 #:log-file "/var/log/pagekite.log"))
        ;; SIGTERM doesn't always work for some reason.
        (stop #~(make-kill-destructor SIGINT))))))
 
-- 
2.41.0

[bug#67175] [PATCH 2/9] services: pagekite: Add ‘configuration’ action.

[Ludovic Courtès]

* gnu/services/networking.scm (pagekite-shepherd-service): Add ‘actions’
field.

Change-Id: I04daa846d505b0700b574a82472ecd99b492d7c4
---
 gnu/services/networking.scm | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index d3376f9acb..7c114fa53c 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -1938,6 +1938,7 @@ (define (pagekite-shepherd-service config)
        (documentation "Run the PageKite service.")
        (provision '(pagekite))
        (requirement '(networking))
+       (actions (list (shepherd-configuration-action config-file)))
        (start #~(make-forkexec-constructor
                  (list #$pagekite
                        "--clean"
-- 
2.41.0

[bug#67175] [PATCH 3/9] services: bitlbee: Remove use of ‘make-forkexec-constructor/container’.

[Ludovic Courtès]

This will only affect systems running Shepherd < 0.9.0, which was
released in August 2022.

* gnu/services/messaging.scm (bitlbee-shepherd-service): Remove
‘with-imported-modules’ and ‘modules’ field.  Use
‘make-forkexec-constructor’ instead of
‘make-forkexec-constructor/container’ when ‘make-inetd-constructor’ is
missing.

Change-Id: I35a0487bccaee4799ad0d81388d540e5c7891f7e
---
 gnu/services/messaging.scm | 77 +++++++++++++++++---------------------
 1 file changed, 34 insertions(+), 43 deletions(-)

diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
index c4963936a0..7505810e7c 100644
--- a/gnu/services/messaging.scm
+++ b/gnu/services/messaging.scm
@@ -849,56 +849,47 @@ (define bitlbee-shepherd-service
                                          (target conf)))
                        #:namespaces (delq 'net %namespaces))))
 
-       (with-imported-modules (source-module-closure
-                               '((gnu build shepherd)
-                                 (gnu system file-systems)))
-         (list (shepherd-service
-                (provision '(bitlbee))
+       (list (shepherd-service
+              (provision '(bitlbee))
 
-                ;; Note: If networking is not up, then /etc/resolv.conf
-                ;; doesn't get mapped in the container, hence the dependency
-                ;; on 'networking'.
-                (requirement '(user-processes networking))
+              ;; Note: If networking is not up, then /etc/resolv.conf
+              ;; doesn't get mapped in the container, hence the dependency
+              ;; on 'networking'.
+              (requirement '(user-processes networking))
 
-                (modules '((gnu build shepherd)
-                           (gnu system file-systems)))
-                (start #~(if (defined? 'make-inetd-constructor)
+              (start #~(if (defined? 'make-inetd-constructor)
 
-                             (make-inetd-constructor
-                              (list #$bitlbee* "-I" "-c" #$conf)
-                              (list (endpoint
-                                     (addrinfo:addr
-                                      (car (getaddrinfo #$interface
-                                                        #$(number->string port)
-                                                        (logior AI_NUMERICHOST
-                                                                AI_NUMERICSERV))))))
-                              #:requirements '#$requirement
-                              #:service-name-stem "bitlbee"
-                              #:user "bitlbee" #:group "bitlbee"
+                           (make-inetd-constructor
+                            (list #$bitlbee* "-I" "-c" #$conf)
+                            (list (endpoint
+                                   (addrinfo:addr
+                                    (car (getaddrinfo #$interface
+                                                      #$(number->string port)
+                                                      (logior AI_NUMERICHOST
+                                                              AI_NUMERICSERV))))))
+                            #:requirements '#$requirement
+                            #:service-name-stem "bitlbee"
+                            #:user "bitlbee" #:group "bitlbee"
 
-                              ;; Allow 'bitlbee-purple' to use libpurple plugins.
-                              #:environment-variables
-                              (list (string-append "PURPLE_PLUGIN_PATH="
-                                                   #$plugins "/lib/purple-2")
-                                    "GUIX_LOCPATH=/run/current-system/locale"))
+                            ;; Allow 'bitlbee-purple' to use libpurple plugins.
+                            #:environment-variables
+                            (list (string-append "PURPLE_PLUGIN_PATH="
+                                                 #$plugins "/lib/purple-2")
+                                  "GUIX_LOCPATH=/run/current-system/locale"))
 
-                             (make-forkexec-constructor/container
-                              (list #$(file-append bitlbee "/sbin/bitlbee")
-                                    "-n" "-F" "-u" "bitlbee" "-c" #$conf)
+                           (make-forkexec-constructor
+                            (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"))
+                            ;; 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  #~(if (defined? 'make-inetd-destructor)
-                             (make-inetd-destructor)
-                             (make-kill-destructor))))))))))
+                            #:pid-file "/var/run/bitlbee.pid")))
+              (stop  #~(if (defined? 'make-inetd-destructor)
+                           (make-inetd-destructor)
+                           (make-kill-destructor)))))))))
 
 (define %bitlbee-accounts
   ;; User group and account to run BitlBee.
-- 
2.41.0

[bug#67175] [PATCH 4/9] least-authority: Add support for changing UIDs/GIDs before exec.

[Ludovic Courtès]

* guix/least-authority.scm (least-authority-wrapper): Add #:user
and #:group.
[code]: Add calls to ‘setgid’ and ‘setuid’ when appropriate.

Change-Id: I2aad8e5686b42b5c92fc306b114c5c60cb8bc551
---
 guix/least-authority.scm | 25 +++++++++++++++++++++++--
 1 file changed, 23 insertions(+), 2 deletions(-)

diff --git a/guix/least-authority.scm b/guix/least-authority.scm
index bfd7275e7c..3465fe9a48 100644
--- a/guix/least-authority.scm
+++ b/guix/least-authority.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2022-2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,6 +41,8 @@ (define %precious-variables
 
 (define* (least-authority-wrapper program
                                   #:key (name "pola-wrapper")
+                                  (user #f)
+                                  (group #f)
                                   (guest-uid 1000)
                                   (guest-gid 1000)
                                   (mappings '())
@@ -55,7 +57,11 @@ (define* (least-authority-wrapper program
 <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."
+is preserved; other environment variables are erased.
+
+When USER and GROUP are set and NAMESPACES does not include 'user, change UIDs
+and GIDs to these prior to executing PROGRAM.  This usually requires that the
+resulting wrapper be executed as root so it can call setgid(2) and setuid(2)."
   (define code
     (with-imported-modules (source-module-closure
                             '((gnu system file-systems)
@@ -113,6 +119,10 @@ (define* (least-authority-wrapper program
                                 #$program signal)
                         (exit (+ 128 signal))))))
 
+          (define namespaces '#$namespaces)
+          (define host-group '#$group)
+          (define host-user '#$user)
+
           ;; 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
@@ -123,6 +133,17 @@ (define* (least-authority-wrapper program
              (lambda ()
                (chdir #$directory)
                (environ variables)
+
+               (unless (memq 'user namespaces)
+                 ;; This process lives in its parent user namespace,
+                 ;; presumably as root; now is the time to setgid/setuid if
+                 ;; asked for it (the 'clone' call would fail with EPERM if we
+                 ;; changed UIDs/GIDs beforehand).
+                 (when host-group
+                   (setgid (group:gid (getgr host-group))))
+                 (when host-user
+                   (setuid (passwd:uid (getpw host-user)))))
+
                (apply execl #$program #$program (cdr (command-line))))
 
              ;; Don't assume PROGRAM can behave as an init process.
-- 
2.41.0

[bug#67175] [PATCH 5/9] tests: jami: Check status of Jami D-Bus session.

[Ludovic Courtès]

* gnu/tests/telephony.scm (run-jami-test)["dbus session is up"]: New
test.

Change-Id: Ifa9b57c732f3c64e1ec6bf3028b69a57cee56320
---
 gnu/tests/telephony.scm | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/gnu/tests/telephony.scm b/gnu/tests/telephony.scm
index 442258dbc3..f159e970f7 100644
--- a/gnu/tests/telephony.scm
+++ b/gnu/tests/telephony.scm
@@ -184,6 +184,15 @@ (define* (run-jami-test #:key provisioning? partial?)
                 %load-path)
              marionette))
 
+          (test-assert "dbus session is up"
+            (and (marionette-eval
+                  '(begin
+                     (use-modules (gnu services herd))
+                     (wait-for-service 'jami-dbus-session))
+                  marionette)
+                 (wait-for-unix-socket "/var/run/jami/bus"
+                                       marionette)))
+
           (test-assert "service is running"
             (marionette-eval
              '(begin
-- 
2.41.0

[bug#67175] [PATCH 6/9] services: jami-dbus-session: Use ‘least-authority-wrapper’.

[Ludovic Courtès]

* gnu/services/telephony.scm (jami-shepherd-services): Use
‘least-authority-wrapper’ for ‘dbus-daemon’.  Use ‘fork+exec-command’
instead of ‘make-forkexec-constructor/container’ in the ‘start’ method’.
Remove reference to (gnu build shepherd).

Change-Id: I9d9f8de6ecea77950000ff64aa8c8d097dc028a0
---
 gnu/services/telephony.scm | 66 +++++++++++++++++++++++++-------------
 1 file changed, 43 insertions(+), 23 deletions(-)

diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm
index c9b5d6cd99..832470527d 100644
--- a/gnu/services/telephony.scm
+++ b/gnu/services/telephony.scm
@@ -34,6 +34,9 @@ (define-module (gnu services telephony)
   #:use-module (guix modules)
   #:use-module (guix packages)
   #:use-module (guix gexp)
+  #:autoload   (guix least-authority) (least-authority-wrapper)
+  #:autoload   (gnu system file-systems) (file-system-mapping)
+  #:autoload   (gnu build linux-container) (%namespaces)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
@@ -298,7 +301,28 @@ (define (jami-shepherd-services config)
   (let* ((libjami (jami-configuration-libjami config))
          (nss-certs (jami-configuration-nss-certs config))
          (dbus (jami-configuration-dbus config))
-         (dbus-daemon (file-append dbus "/bin/dbus-daemon"))
+         (dbus-daemon (least-authority-wrapper
+                       (file-append dbus "/bin/dbus-daemon")
+                       #:name "dbus-daemon"
+                       #:user "jami"
+                       #:group "jami"
+                       #:preserved-environment-variables
+                       '("XDG_DATA_DIRS")
+                       #:mappings
+                       (list (file-system-mapping
+                              (source "/dev/log") ;for syslog
+                              (target source))
+                             (file-system-mapping
+                              (source "/var/run/jami")
+                              (target source)
+                              (writable? #t))
+                             (file-system-mapping
+                              (source (gexp-input libjami "bin"))
+                              (target source)))
+                       ;; 'dbus-daemon' wants to look up users in /etc/passwd
+                       ;; so run it in the global user namespace.
+                       #:namespaces
+                       (fold delq %namespaces '(net user))))
          (accounts (jami-configuration-accounts config))
          (declarative-mode? (maybe-value-set? accounts)))
 
@@ -490,8 +514,7 @@ (define (jami-shepherd-services config)
         (list (shepherd-service
                (documentation "Run a D-Bus session for the Jami daemon.")
                (provision '(jami-dbus-session))
-               (modules `((gnu build shepherd)
-                          (gnu build dbus-service)
+               (modules `((gnu build dbus-service)
                           (gnu build jami-service)
                           (gnu system file-systems)
                           ,@%default-modules))
@@ -499,26 +522,23 @@ (define (jami-shepherd-services config)
                ;; activation for D-Bus, such as a /etc/machine-id file.
                (requirement '(dbus-system syslogd))
                (start
-                #~(make-forkexec-constructor/container
-                   (list #$dbus-daemon "--session"
-                         "--address=unix:path=/var/run/jami/bus"
-                         "--syslog-only")
-                   #:pid-file "/var/run/jami/pid"
-                   #:mappings
-                   (list (file-system-mapping
-                          (source "/dev/log") ;for syslog
-                          (target source))
-                         (file-system-mapping
-                          (source "/var/run/jami")
-                          (target source)
-                          (writable? #t)))
-                   #:user "jami"
-                   #:group "jami"
-                   #:environment-variables
-                   ;; This is so that the cx.ring.Ring service D-Bus
-                   ;; definition is found by dbus-daemon.
-                   (list (string-append "XDG_DATA_DIRS="
-                                        #$libjami:bin "/share"))))
+                #~(lambda ()
+                    (define pid
+                      (fork+exec-command
+                       (list #$dbus-daemon "--session"
+                             "--address=unix:path=/var/run/jami/bus"
+                             "--syslog-only")
+                       #:environment-variables
+                       ;; This is so that the cx.ring.Ring service D-Bus
+                       ;; definition is found by dbus-daemon.
+                       (list (string-append "XDG_DATA_DIRS="
+                                            #$libjami:bin "/share"))))
+
+                    ;; The PID file contains the "wrong" PID (the one in the
+                    ;; separate PID namespace) so ignore it and return the
+                    ;; value returned by 'fork+exec-command'.
+                    (and (read-pid-file "/var/run/jami/pid")
+                         pid)))
                (stop #~(make-kill-destructor)))
 
               (shepherd-service
-- 
2.41.0

[bug#67175] [PATCH 7/9] services: jami: Use ‘least-authority-wrapper’.

[Ludovic Courtès]

* gnu/services/telephony.scm (jami-configuration->command-line-arguments)
[wrapper]: New procedure.
Use it.
(jami-shepherd-services): In ‘start’ method of ‘jami’ service, use
‘fork+exec-command’ instead of ‘make-forkexec-constructor/container’.
Remove use of (gnu build shepherd).

Change-Id: Ic71c0c88477d92bf137d9d0a5832bae8721cc210
---
 gnu/services/telephony.scm | 66 +++++++++++++++++++++-----------------
 1 file changed, 37 insertions(+), 29 deletions(-)

diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm
index 832470527d..16d109b8b1 100644
--- a/gnu/services/telephony.scm
+++ b/gnu/services/telephony.scm
@@ -261,9 +261,37 @@ (define %jami-accounts
 (define (jami-configuration->command-line-arguments config)
   "Derive the command line arguments to used to launch the Jami daemon from
 CONFIG, a <jami-configuration> object."
+  (define (wrapper libjami)
+    (least-authority-wrapper
+     ;; XXX: 'gexp-input' is needed as the outer layer so that
+     ;; 'references-file' picks the right output of LIBJAMI.
+     (gexp-input (file-append (gexp-input libjami "bin") "/libexec/jamid")
+                 "bin")
+     #:mappings
+     (list (file-system-mapping
+            (source "/dev/log") ;for syslog
+            (target source))
+           (file-system-mapping
+            (source "/var/lib/jami")
+            (target source)
+            (writable? #t))
+           (file-system-mapping
+            (source "/var/run/jami")
+            (target source)
+            (writable? #t))
+           ;; Expose TLS certificates for GnuTLS.
+           (file-system-mapping
+            (source (file-append nss-certs "/etc/ssl/certs"))
+            (target "/etc/ssl/certs")))
+     #:preserved-environment-variables
+     '("DBUS_SESSION_BUS_ADDRESS" "SSL_CERT_DIR")
+     #:user "jami"
+     #:group "jami"
+     #:namespaces (fold delq %namespaces '(net user))))
+
   (match-record config <jami-configuration>
     (libjami dbus enable-logging? debug? auto-answer?)
-    `(,#~(string-append #$libjami:bin "/libexec/jamid")
+    `(,(wrapper libjami)
       "--persistent"                    ;stay alive after client quits
       ,@(if enable-logging?
             '()                         ;logs go to syslog by default
@@ -334,7 +362,6 @@ (define (jami-shepherd-services config)
       (with-imported-modules (source-module-closure
                               '((gnu build dbus-service)
                                 (gnu build jami-service)
-                                (gnu build shepherd)
                                 (gnu system file-systems)))
 
         (define list-accounts-action
@@ -562,7 +589,6 @@ (define (jami-shepherd-services config)
                           (srfi srfi-26)
                           (gnu build dbus-service)
                           (gnu build jami-service)
-                          (gnu build shepherd)
                           (gnu system file-systems)
                           ,@%default-modules))
                (start
@@ -608,32 +634,14 @@ (define (jami-shepherd-services config)
 
                     ;; Start the daemon.
                     (define daemon-pid
-                      ((make-forkexec-constructor/container
-                        (list #$@(jami-configuration->command-line-arguments
-                                  config))
-                        #:mappings
-                        (list (file-system-mapping
-                               (source "/dev/log") ;for syslog
-                               (target source))
-                              (file-system-mapping
-                               (source "/var/lib/jami")
-                               (target source)
-                               (writable? #t))
-                              (file-system-mapping
-                               (source "/var/run/jami")
-                               (target source)
-                               (writable? #t))
-                              ;; Expose TLS certificates for GnuTLS.
-                              (file-system-mapping
-                               (source #$(file-append nss-certs "/etc/ssl/certs"))
-                               (target "/etc/ssl/certs")))
-                        #:user "jami"
-                        #:group "jami"
-                        #:environment-variables
-                        (list (string-append "DBUS_SESSION_BUS_ADDRESS="
-                                             "unix:path=/var/run/jami/bus")
-                              ;; Expose TLS certificates for OpenSSL.
-                              "SSL_CERT_DIR=/etc/ssl/certs"))))
+                      (fork+exec-command
+                       (list #$@(jami-configuration->command-line-arguments
+                                 config))
+                       #:environment-variables
+                       (list (string-append "DBUS_SESSION_BUS_ADDRESS="
+                                            "unix:path=/var/run/jami/bus")
+                             ;; Expose TLS certificates for OpenSSL.
+                             "SSL_CERT_DIR=/etc/ssl/certs")))
 
                     (setenv "DBUS_SESSION_BUS_ADDRESS"
                             "unix:path=/var/run/jami/bus")
-- 
2.41.0

[bug#67175] [PATCH 8/9] services: Remove unnecessary references to (gnu build shepherd).

[Ludovic Courtès]

* gnu/services/databases.scm (memcached-shepherd-service): Remove
‘with-imported-modules’ form and ‘modules’ field.
* gnu/services/security-token.scm (pcscd-shepherd-service): Remove
‘with-imported-modules’ form.
* gnu/services/web.scm (hpcguix-web-shepherd-service): Likewise.

Change-Id: Ieb817508f1751e0c1ff551a0e078789a4a813c1c
---
 gnu/services/databases.scm      | 41 +++++++++++++--------------
 gnu/services/security-token.scm | 29 +++++++++----------
 gnu/services/web.scm            | 50 ++++++++++++++++-----------------
 3 files changed, 56 insertions(+), 64 deletions(-)

diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm
index d3fee2a8ef..580031cb42 100644
--- a/gnu/services/databases.scm
+++ b/gnu/services/databases.scm
@@ -512,28 +512,25 @@ (define memcached-shepherd-service
   (match-lambda
     (($ <memcached-configuration> memcached interfaces tcp-port udp-port
                                   additional-options)
-     (with-imported-modules (source-module-closure
-                             '((gnu build shepherd)))
-       (list (shepherd-service
-              (provision '(memcached))
-              (documentation "Run the Memcached daemon.")
-              (requirement '(user-processes loopback))
-              (modules '((gnu build shepherd)))
-              (start #~(make-forkexec-constructor
-                        `(#$(file-append memcached "/bin/memcached")
-                          "-l" #$(string-join interfaces ",")
-                          "-p" #$(number->string tcp-port)
-                          "-U" #$(number->string udp-port)
-                          "--daemon"
-                          ;; Memcached changes to the memcached user prior to
-                          ;; writing the pid file, so write it to a directory
-                          ;; that memcached owns.
-                          "-P" "/var/run/memcached/pid"
-                          "-u" "memcached"
-                          ,#$@additional-options)
-                        #:log-file "/var/log/memcached"
-                        #:pid-file "/var/run/memcached/pid"))
-              (stop #~(make-kill-destructor))))))))
+     (list (shepherd-service
+            (provision '(memcached))
+            (documentation "Run the Memcached daemon.")
+            (requirement '(user-processes loopback))
+            (start #~(make-forkexec-constructor
+                      `(#$(file-append memcached "/bin/memcached")
+                        "-l" #$(string-join interfaces ",")
+                        "-p" #$(number->string tcp-port)
+                        "-U" #$(number->string udp-port)
+                        "--daemon"
+                        ;; Memcached changes to the memcached user prior to
+                        ;; writing the pid file, so write it to a directory
+                        ;; that memcached owns.
+                        "-P" "/var/run/memcached/pid"
+                        "-u" "memcached"
+                        ,#$@additional-options)
+                      #:log-file "/var/log/memcached"
+                      #:pid-file "/var/run/memcached/pid"))
+            (stop #~(make-kill-destructor)))))))
 
 (define memcached-service-type
   (service-type (name 'memcached)
diff --git a/gnu/services/security-token.scm b/gnu/services/security-token.scm
index 2356273398..d971091e73 100644
--- a/gnu/services/security-token.scm
+++ b/gnu/services/security-token.scm
@@ -50,22 +50,19 @@ (define-record-type* <pcscd-configuration>
 (define pcscd-shepherd-service
   (match-lambda
     (($ <pcscd-configuration> pcsc-lite)
-     (with-imported-modules (source-module-closure
-                             '((gnu build shepherd)))
-       (shepherd-service
-        (documentation "PC/SC Smart Card Daemon")
-        (provision '(pcscd))
-        (requirement '(syslogd))
-        (modules '((gnu build shepherd)))
-        (start #~(lambda _
-                   (let ((socket "/run/pcscd/pcscd.comm"))
-                     (when (file-exists? socket)
-                       (delete-file socket)))
-                   (fork+exec-command
-                    (list #$(file-append pcsc-lite "/sbin/pcscd")
-                          "--foreground")
-                    #:log-file "/var/log/pcscd.log")))
-        (stop #~(make-kill-destructor)))))))
+     (shepherd-service
+      (documentation "PC/SC Smart Card Daemon")
+      (provision '(pcscd))
+      (requirement '(syslogd))
+      (start #~(lambda _
+                 (let ((socket "/run/pcscd/pcscd.comm"))
+                   (when (file-exists? socket)
+                     (delete-file socket)))
+                 (fork+exec-command
+                  (list #$(file-append pcsc-lite "/sbin/pcscd")
+                        "--foreground")
+                  #:log-file "/var/log/pcscd.log")))
+      (stop #~(make-kill-destructor))))))
 
 (define pcscd-activation
   (match-lambda
diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index 818226a4f7..8eb00f76e3 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -1231,32 +1231,30 @@ (define %hpcguix-web-log-rotations
 (define (hpcguix-web-shepherd-service config)
   (let ((specs       (hpcguix-web-configuration-specs config))
         (hpcguix-web (hpcguix-web-package config)))
-    (with-imported-modules (source-module-closure
-                            '((gnu build shepherd)))
-      (shepherd-service
-       (documentation "hpcguix-web daemon")
-       (provision     '(hpcguix-web))
-       (requirement   '(networking))
-       (start #~(make-forkexec-constructor
-                 (list #$(file-append hpcguix-web "/bin/hpcguix-web")
-                       (string-append "--listen="
-                                      #$(hpcguix-web-configuration-address
-                                         config))
-                       "-p"
-                       #$(number->string
-                          (hpcguix-web-configuration-port config))
-                       #$@(if specs
-                              #~((string-append "--config="
-                                                #$(scheme-file
-                                                   "hpcguix-web.scm" specs)))
-                              #~()))
-                 #:user "hpcguix-web"
-                 #:group "hpcguix-web"
-                 #:environment-variables
-                 (list "XDG_CACHE_HOME=/var/cache/guix/web"
-                       "SSL_CERT_DIR=/etc/ssl/certs")
-                 #:log-file #$%hpcguix-web-log-file))
-       (stop #~(make-kill-destructor))))))
+    (shepherd-service
+     (documentation "hpcguix-web daemon")
+     (provision     '(hpcguix-web))
+     (requirement   '(networking))
+     (start #~(make-forkexec-constructor
+               (list #$(file-append hpcguix-web "/bin/hpcguix-web")
+                     (string-append "--listen="
+                                    #$(hpcguix-web-configuration-address
+                                       config))
+                     "-p"
+                     #$(number->string
+                        (hpcguix-web-configuration-port config))
+                     #$@(if specs
+                            #~((string-append "--config="
+                                              #$(scheme-file
+                                                 "hpcguix-web.scm" specs)))
+                            #~()))
+               #:user "hpcguix-web"
+               #:group "hpcguix-web"
+               #:environment-variables
+               (list "XDG_CACHE_HOME=/var/cache/guix/web"
+                     "SSL_CERT_DIR=/etc/ssl/certs")
+               #:log-file #$%hpcguix-web-log-file))
+     (stop #~(make-kill-destructor)))))
 
 (define hpcguix-web-service-type
   (service-type
-- 
2.41.0

[bug#67175] [PATCH 9/9] shepherd: Remove ‘make-forkexec-constructor/container’.

[Ludovic Courtès]

This was superseded by ‘least-authority-wrapper’.

* gnu/build/shepherd.scm (read-pid-file/container)
(make-forkexec-constructor/container): Remove.

Change-Id: I6acccdff2609a35807608f865a4d381146113a88
---
 gnu/build/shepherd.scm | 90 ------------------------------------------
 1 file changed, 90 deletions(-)

diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index 9d9bfcfbc0..4ead27be0b 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -33,7 +33,6 @@ (define-module (gnu build shepherd)
                                  %precious-signals)
   #:autoload (shepherd system) (unblock-signals)
   #:export (default-mounts
-            make-forkexec-constructor/container
             fork+exec-command/container))
 
 ;;; Commentary:
@@ -101,27 +100,6 @@ (define* (default-mounts #:key (namespaces (default-namespaces '())))
                            (file-exists? (file-system-mapping-source mapping)))
                          mappings)))))
 
-(define* (read-pid-file/container pid pid-file #:key (max-delay 5))
-  "Read PID-FILE in the container namespaces of PID, which exists in a
-separate mount and PID name space.  Return the \"outer\" PID. "
-  (match (container-excursion* pid
-           (lambda ()
-             ;; XXX: Trick for Shepherd 0.9: prevent 'read-pid-file' from
-             ;; using (@ (fibers) sleep), which would try to suspend the
-             ;; current task, which doesn't work in this extra process.
-             (with-continuation-barrier
-              (lambda ()
-                (read-pid-file pid-file
-                               #:max-delay max-delay)))))
-    (#f
-     ;; Send SIGTERM to the whole process group.
-     (catch-system-error (kill (- pid) SIGTERM))
-     #f)
-    ((? integer? container-pid)
-     ;; XXX: When COMMAND is started in a separate PID namespace, its
-     ;; PID is always 1, but that's not what Shepherd needs to know.
-     pid)))
-
 (define* (exec-command* command #:key user group log-file pid-file
                         (supplementary-groups '())
                         (directory "/") (environment-variables (environ)))
@@ -144,74 +122,6 @@ (define* (exec-command* command #:key user group log-file pid-file
                 #:directory directory
                 #:environment-variables environment-variables))
 
-(define* (make-forkexec-constructor/container command
-                                              #:key
-                                              (namespaces
-                                               (default-namespaces args))
-                                              (mappings '())
-                                              (user #f)
-                                              (group #f)
-                                              (supplementary-groups '())
-                                              (log-file #f)
-                                              pid-file
-                                              (pid-file-timeout 5)
-                                              (directory "/")
-                                              (environment-variables
-                                               (environ))
-                                              #:rest args)
-  "This is a variant of 'make-forkexec-constructor' that starts COMMAND in
-NAMESPACES, a list of Linux namespaces such as '(mnt ipc).  MAPPINGS is the
-list of <file-system-mapping> to make in the case of a separate mount
-namespace, in addition to essential bind-mounts such /proc."
-  (define container-directory
-    (match command
-      ((program _  ...)
-       (string-append "/var/run/containers/" (basename program)))))
-
-  (define auto-mappings
-    `(,@(if log-file
-            (list (file-system-mapping
-                   (source log-file)
-                   (target source)
-                   (writable? #t)))
-            '())))
-
-  (define mounts
-    (append (map file-system-mapping->bind-mount
-                 (append auto-mappings mappings))
-            (default-mounts #:namespaces namespaces)))
-
-  (lambda args
-    (mkdir-p container-directory)
-
-    (when log-file
-      ;; Create LOG-FILE so we can map it in the container.
-      (unless (file-exists? log-file)
-        (close (open log-file (logior O_CREAT O_APPEND O_CLOEXEC) #o640))
-        (when user
-          (let ((pw (getpwnam user)))
-            (chown log-file (passwd:uid pw) (passwd:gid pw))))))
-
-    (let ((pid (run-container container-directory
-                              mounts namespaces 1
-                              (lambda ()
-                                (exec-command* command
-                                               #:user user
-                                               #:group group
-                                               #:supplementary-groups
-                                               supplementary-groups
-                                               #:pid-file pid-file
-                                               #:log-file log-file
-                                               #:directory directory
-                                               #:environment-variables
-                                               environment-variables)))))
-      (if pid-file
-          (if (or (memq 'mnt namespaces) (memq 'pid namespaces))
-              (read-pid-file/container pid pid-file
-                                       #:max-delay pid-file-timeout)
-              (read-pid-file pid-file #:max-delay pid-file-timeout))
-          pid))))
-
 (define* (fork+exec-command/container command
                                       #:key pid
                                       #:allow-other-keys
-- 
2.41.0

[bug#67175] [PATCH 7/9] services: jami: Use ‘least-authority-wrapper’.

[Maxim Cournoyer]

Hi,

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

> * gnu/services/telephony.scm (jami-configuration->command-line-arguments)
> [wrapper]: New procedure.

nitpick: Should be <wrapper>, according to 'info (standards) Indicating
the Part Changed'

> Use it.
> (jami-shepherd-services): In ‘start’ method of ‘jami’ service, use
> ‘fork+exec-command’ instead of ‘make-forkexec-constructor/container’.
> Remove use of (gnu build shepherd).
>
> Change-Id: Ic71c0c88477d92bf137d9d0a5832bae8721cc210
> ---
>  gnu/services/telephony.scm | 66 +++++++++++++++++++++-----------------
>  1 file changed, 37 insertions(+), 29 deletions(-)
>
> diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm
> index 832470527d..16d109b8b1 100644
> --- a/gnu/services/telephony.scm
> +++ b/gnu/services/telephony.scm
> @@ -261,9 +261,37 @@ (define %jami-accounts
>  (define (jami-configuration->command-line-arguments config)
>    "Derive the command line arguments to used to launch the Jami daemon from
>  CONFIG, a <jami-configuration> object."
> +  (define (wrapper libjami)
> +    (least-authority-wrapper
> +     ;; XXX: 'gexp-input' is needed as the outer layer so that
> +     ;; 'references-file' picks the right output of LIBJAMI.

It seems clearer to me to stick to the current #~(string-append
#$libjami:bin "/libexec/jamid") until file-append can handle non-default
outputs more elegantly (did we have a bug for that? -- I couldn't find
one).

The rest LGTM, if both jami system tests pass.

-- 
Thanks,
Maxim

[bug#67175] [PATCH 5/9] tests: jami: Check status of Jami D-Bus session.

[Maxim Cournoyer]

Hi,

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

> * gnu/tests/telephony.scm (run-jami-test)["dbus session is up"]: New
> test.
>
> Change-Id: Ifa9b57c732f3c64e1ec6bf3028b69a57cee56320
> ---
>  gnu/tests/telephony.scm | 9 +++++++++
>  1 file changed, 9 insertions(+)
>
> diff --git a/gnu/tests/telephony.scm b/gnu/tests/telephony.scm
> index 442258dbc3..f159e970f7 100644
> --- a/gnu/tests/telephony.scm
> +++ b/gnu/tests/telephony.scm
> @@ -184,6 +184,15 @@ (define* (run-jami-test #:key provisioning? partial?)
>                  %load-path)
>               marionette))
>  
> +          (test-assert "dbus session is up"
> +            (and (marionette-eval
> +                  '(begin
> +                     (use-modules (gnu services herd))
> +                     (wait-for-service 'jami-dbus-session))
> +                  marionette)
> +                 (wait-for-unix-socket "/var/run/jami/bus"
> +                                       marionette)))
> +
>            (test-assert "service is running"
>              (marionette-eval
>               '(begin

Reviewed-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>

-- 
Thanks,
Maxim

[bug#67175] [PATCH 6/9] services: jami-dbus-session: Use ‘least-authority-wrapper’.

[Maxim Cournoyer]

Hello!

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

> * gnu/services/telephony.scm (jami-shepherd-services): Use
> ‘least-authority-wrapper’ for ‘dbus-daemon’.  Use ‘fork+exec-command’
> instead of ‘make-forkexec-constructor/container’ in the ‘start’ method’.
> Remove reference to (gnu build shepherd).

Reviewed-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>

-- 
Thanks,
Maxim

[bug#67175] [PATCH 4/9] least-authority: Add support for changing UIDs/GIDs before exec.

[Maxim Cournoyer]

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

> * guix/least-authority.scm (least-authority-wrapper): Add #:user
> and #:group.
> [code]: Add calls to ‘setgid’ and ‘setuid’ when appropriate.
>
> Change-Id: I2aad8e5686b42b5c92fc306b114c5c60cb8bc551

This should mention it fixes bug #67175 :-).

> ---
>  guix/least-authority.scm | 25 +++++++++++++++++++++++--
>  1 file changed, 23 insertions(+), 2 deletions(-)
>
> diff --git a/guix/least-authority.scm b/guix/least-authority.scm
> index bfd7275e7c..3465fe9a48 100644
> --- a/guix/least-authority.scm
> +++ b/guix/least-authority.scm
> @@ -1,5 +1,5 @@
>  ;;; GNU Guix --- Functional package management for GNU
> -;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
> +;;; Copyright © 2022-2023 Ludovic Courtès <ludo@gnu.org>
>  ;;;
>  ;;; This file is part of GNU Guix.
>  ;;;
> @@ -41,6 +41,8 @@ (define %precious-variables
>  
>  (define* (least-authority-wrapper program
>                                    #:key (name "pola-wrapper")
> +                                  (user #f)
> +                                  (group #f)
>                                    (guest-uid 1000)
>                                    (guest-gid 1000)
>                                    (mappings '())
> @@ -55,7 +57,11 @@ (define* (least-authority-wrapper program
>  <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."
> +is preserved; other environment variables are erased.
> +
> +When USER and GROUP are set and NAMESPACES does not include 'user, change UIDs
> +and GIDs to these prior to executing PROGRAM.  This usually requires that the
> +resulting wrapper be executed as root so it can call setgid(2) and
>  setuid(2)."

About "usually"; in which case could a programm call to setgid and
setuid without being root?

>    (define code
>      (with-imported-modules (source-module-closure
>                              '((gnu system file-systems)
> @@ -113,6 +119,10 @@ (define* (least-authority-wrapper program
>                                  #$program signal)
>                          (exit (+ 128 signal))))))
>  
> +          (define namespaces '#$namespaces)
> +          (define host-group '#$group)
> +          (define host-user '#$user)
> +
>            ;; 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
> @@ -123,6 +133,17 @@ (define* (least-authority-wrapper program
>               (lambda ()
>                 (chdir #$directory)
>                 (environ variables)
> +
> +               (unless (memq 'user namespaces)
> +                 ;; This process lives in its parent user namespace,
> +                 ;; presumably as root; now is the time to setgid/setuid if
> +                 ;; asked for it (the 'clone' call would fail with EPERM if we
> +                 ;; changed UIDs/GIDs beforehand).

Related to my previous interrogation, should we check if the current
user id is 0 (root), and fail otherwise with an informative message?

-- 
Thanks,
Maxim

[bug#67175] [PATCH 4/9] least-authority: Add support for changing UIDs/GIDs before exec.

[Ludovic Courtès]

Hi!

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> * guix/least-authority.scm (least-authority-wrapper): Add #:user
>> and #:group.
>> [code]: Add calls to ‘setgid’ and ‘setuid’ when appropriate.
>>
>> Change-Id: I2aad8e5686b42b5c92fc306b114c5c60cb8bc551
>
> This should mention it fixes bug #67175 :-).

Noted!

>>  (define* (least-authority-wrapper program
>>                                    #:key (name "pola-wrapper")
>> +                                  (user #f)
>> +                                  (group #f)
>>                                    (guest-uid 1000)
>>                                    (guest-gid 1000)
>>                                    (mappings '())
>> @@ -55,7 +57,11 @@ (define* (least-authority-wrapper program
>>  <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."
>> +is preserved; other environment variables are erased.
>> +
>> +When USER and GROUP are set and NAMESPACES does not include 'user, change UIDs
>> +and GIDs to these prior to executing PROGRAM.  This usually requires that the
>> +resulting wrapper be executed as root so it can call setgid(2) and
>>  setuid(2)."
>
> About "usually"; in which case could a programm call to setgid and
> setuid without being root?

On Linux, a non-root process can have ‘CAP_SETGID’ and/or ‘CAP_SETUID’
and successfully call these.

So checking whether the UID is zero would not be accurate (tricky
semantics).  I think it’s safer to let it fail and display the actual
error.

Thanks,
Ludo’.

[bug#67175] [PATCH 7/9] services: jami: Use ‘least-authority-wrapper’.

[Ludovic Courtès]

Hi,

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> * gnu/services/telephony.scm (jami-configuration->command-line-arguments)
>> [wrapper]: New procedure.
>
> nitpick: Should be <wrapper>, according to 'info (standards) Indicating
> the Part Changed'

OK.

>> +  (define (wrapper libjami)
>> +    (least-authority-wrapper
>> +     ;; XXX: 'gexp-input' is needed as the outer layer so that
>> +     ;; 'references-file' picks the right output of LIBJAMI.
>
> It seems clearer to me to stick to the current #~(string-append
> #$libjami:bin "/libexec/jamid") until file-append can handle non-default
> outputs more elegantly (did we have a bug for that? -- I couldn't find
> one).

We cannot write #~(string-append …) here because
‘least-authority-wrapper’ expects a file-like object (because it passes
it to ‘references-file’).

> The rest LGTM, if both jami system tests pass.

Alright!

Ludo’.

bug#67175: [PATCH 7/9] services: jami: Use ‘least-authority-wrapper’.

[Ludovic Courtès]

Pushed as commit ca813173894360edef35a5d98878a3135e99e62a after
double-checking with:

  make check-system TESTS="jami jami-provisioning jami-provisioning-partial"

I inserted a new commit, 2cc881ac13522566a27d996afd1fb88df363f75e, to
increase timeouts in the tests: on my laptop the three tests would
occasionally fail when using the initial 20s timeouts (it’s not “really”
20s as the time measured in the host, not in the guest).

Thanks,
Ludo’.