Subject: bug#52051: [core-updates-frozen] cannot login ('org.freedesktop.login1' service times out)

From: Maxim Cournoyer <[email-masked]>
Date: Fri, 10 Dec 2021 00:09:28 -0500

Hello Ludovic!

Ludovic Courtès <[email-masked]> writes:

> Hello!
>
> Maxim Cournoyer <[email-masked]> skribis:
>
>> 374   connect(11, {sa_family=AF_UNIX, sun_path="/var/run/dbus/system_bus_socket"}, 34) = 0
>
> [...]
>
>> 374   epoll_wait(5, [{events=EPOLLIN|EPOLLOUT|EPOLLHUP, data={u32=24802800, u64=24802800}}], 20, -1) = 1
>> 374 sendmsg(11, {msg_name=NULL, msg_namelen=0,
>> msg_iov=[{iov_base="l\1\0\1\0\0\0\0\1\0\0\0m\0\0\0\1\1o\0\25\0\0\0/org/freedesktop/DBus\0\0\0\3\1s\0\5\0\0\0Hello\0\0\0\2\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0\6\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0",
>> iov_len=128}], msg_iovlen=1, msg_controllen=0, msg_flags=0},
>> MSG_DONTWAIT|MSG_NOSIGNAL) = -1 EPIPE (Broken pipe)
>> 374   gettid()                          = 374
>> 374   epoll_ctl(5, EPOLL_CTL_MOD, 11, {events=0, data={u32=24802800, u64=24802800}}) = 0
>> 374   timerfd_settime(12, TFD_TIMER_ABSTIME, {it_interval={tv_sec=0, tv_nsec=0}, it_value={tv_sec=0, tv_nsec=1}}, NULL) = 0
>> 374   epoll_wait(5, [{events=EPOLLHUP, data={u32=24802800, u64=24802800}}, {events=EPOLLIN, data={u32=24764384, u64=24764384}}], 20, -1) = 2
>> 374   read(12, "\1\0\0\0\0\0\0\0", 8)   = 8
>> 374   gettid()                          = 374
>> 374   timerfd_settime(12, TFD_TIMER_ABSTIME, {it_interval={tv_sec=0, tv_nsec=0}, it_value={tv_sec=0, tv_nsec=1}}, NULL) = 0
>> 374   epoll_wait(5, [{events=EPOLLHUP, data={u32=24802800, u64=24802800}}, {events=EPOLLIN, data={u32=24764384, u64=24764384}}], 20, -1) = 2
>> 374   read(12, "\1\0\0\0\0\0\0\0", 8)   = 8
>> 374   gettid()                          = 374
>> 374   timerfd_settime(12, TFD_TIMER_ABSTIME, {it_interval={tv_sec=0, tv_nsec=0}, it_value={tv_sec=0, tv_nsec=1}}, NULL) = 0
>> 374   epoll_wait(5, [{events=EPOLLHUP, data={u32=24802800, u64=24802800}}, {events=EPOLLIN, data={u32=24764384, u64=24764384}}], 20, -1) = 2
>> 374   read(12, "\1\0\0\0\0\0\0\0", 8)   = 8
>> 374   epoll_ctl(5, EPOLL_CTL_DEL, 11, NULL) = 0
>> 374   close(11)                         = 0
>> 374   gettid()                          = 374
>> 374   epoll_wait(5,  <unfinished ...>
>> 391   <... close resumed>)              = 0
>> 391   madvise(0x7fd6c83dc000, 8368128, MADV_DONTNEED) = 0
>> 391   exit(0)                           = ?
>> 391   +++ exited with 0 +++
>> 374   <... epoll_wait resumed>[{events=EPOLLERR, data={u32=24768000, u64=24768000}}], 17, -1) = 1
>> 374   lseek(7, 0, SEEK_SET)             = 0
>> 374   read(7, "tty7\n", 63)             = 5
>
> As you pointed out on IRC, the initially ‘Hello’ method call above leads
> to EPIPE, and we can see that elogind eventually closes its socket to
> dbus-daemon *but* keeps doing its thing.
>
> Some interesting things to note…

Indeed, very interesting :-).  Thanks for diving in!

> First, to my surprise, elogind does not use the client library of the
> ‘dbus’ package:
>
> $ guix gc --references $(./pre-inst-env guix build elogind)|grep dbus
> $ echo $?
> 1
>
>
> (This is already the case in ‘master’ with v243.7.)  Instead, it has its
> own implementation of the DBus protocol, in C, from systemd—we can’t
> have enough sources of bugs and vulnerabilities.

Oh!  Marius found this interesting issue [0] that they shared on IRC
today; I wonder if it may be related.  sd-bus apparently pipeline things
aggressively, which is not always handled well by other D-bus
participants.

[0]  https://github.com/systemd/systemd/issues/16610

> Anyway, the “Hello” message is sent to the system bus asynchronously in
> ‘sd-bus.c’:
>
> static int bus_send_hello(sd_bus *bus) {
>         _cleanup_(sd_bus_message_unrefp) sd_bus_message *m = NULL;
>         int r;
>
>         assert(bus);
>
>         if (!bus->bus_client)
>                 return 0;
>
>         r = sd_bus_message_new_method_call(
>                         bus,
>                         &m,
>                         "org.freedesktop.DBus",
>                         "/org/freedesktop/DBus",
>                         "org.freedesktop.DBus",
>                         "Hello");
>         if (r < 0)
>                 return r;
>
>         return sd_bus_call_async(bus, NULL, m, hello_callback, NULL, 0);
> }
>
>
> A callback is called when a reply is received or an error arises:
>
> static int hello_callback(sd_bus_message *reply, void *userdata, sd_bus_error *error) {
>
> [...]
>
> fail:
>         /* When Hello() failed, let's propagate this in two ways: first we return the error immediately here,
>          * which is the propagated up towards the event loop. Let's also invalidate the connection, so that
>          * if the user then calls back into us again we won't wait any longer. */
>
>         bus_set_state(bus, BUS_CLOSING);
>         return r;
> }
>
>
> It’s not clear from that whether the authors intended for the thing to
> keep going in case of failure.  In our case it’s not helpful.

If we picture this in the systemd use case, I believe sd-bus must be
used as *the* d-bus daemon, perhaps?  So it should never die, and expect
users to call back into it to retry things?  In our case, it acts as a
D-Bus client, not a server (IIUC), so perhaps its behavior is not tuned
right for our use case.

> But why does dbus-daemon drop the connection in the first place?
>
> To know that, we could change ‘dbus-root-service-type’ to run
> dbus-daemon from a ‘--enable-verbose-mode’ build, and with the
> ‘DBUS_VERBOSE’ environment set to 1.
>
> Looking at ‘dbus-server-socket.c’ it would seem that the only sensible
> way this can happen is if dbus-daemon doesn’t yet have a
> ‘new_connection_function’ set at the time it accepts the incoming
> connection:

Interesting that you mention this; that's what I worked on yesterday
(see attached patches).  I managed to get elogind panicking the kernel
during a guix system reconfigure, which corrupted GRUB, so had to chroot
and reconfigure from there [1].  Not sure what happened, but it seems
that killing and restarting elogind is susceptible to cause hard locks.

[1]  https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00202.html

>From 690d96cba581f253761e6c3263262fbc899aa2a2 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <[email-masked]>
Date: Tue, 7 Dec 2021 22:20:02 -0500
Subject: [PATCH 1/5] gnu: Add dbus-verbose.

* gnu/packages/glib.scm (dbus-verbose): New variable.
---
 gnu/packages/glib.scm | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/gnu/packages/glib.scm b/gnu/packages/glib.scm
index 398d3943e5..2eead335f5 100644
--- a/gnu/packages/glib.scm
+++ b/gnu/packages/glib.scm
@@ -176,6 +176,21 @@ (define dbus
 shared NFS home directories.")
     (license license:gpl2+)))                     ; or Academic Free License 2.1
 
+;;; The reason this is not enabled in the regular dbus package is because it
+;;; impacts the performance of D-Bus (including its library) as a whole, even
+;;; when the DBUS_VERBOSE environment variable is not set.
+(define-public dbus-verbose
+  (package/inherit dbus
+    (name "dbus-verbose")
+    (arguments (substitute-keyword-arguments (package-arguments dbus)
+                 ((#:configure-flags flags '())
+                  `(cons "--enable-verbose-mode" ,flags))))
+    (synopsis "D-Bus with verbose mode enabled for debugging")
+    (description "This variant D-Bus package is built with verbose mode, which
+eases debugging of D-Bus services by printing various debug information when
+the @code{DBUS_VERBOSE} environment variable is set to @samp{1}.  For more
+information, refer to the @samp{dbus-daemon(1)} man page.")))
+
 (define glib
   (package
     (name "glib")
-- 
2.34.0

>From c614159fbc539c8b1f556fe9ced2d13963b6d6f9 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <[email-masked]>
Date: Tue, 7 Dec 2021 22:48:39 -0500
Subject: [PATCH 2/5] services: dbus: Add a VERBOSE? configuration option.

* gnu/services/dbus.scm (<dbus-configuration>)[verbose?]: New field.
(dbus-shepherd-service): Use it.
(dbus-service)[verbose?]: Add argument and update doc.
* doc/guix.texi (Desktop Services): Document it.
---
 doc/guix.texi         |  9 +++++++--
 gnu/services/dbus.scm | 20 +++++++++++++++-----
 2 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 58625666c1..4b1297e5de 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -20280,9 +20280,14 @@ The actual service definitions included in @code{%desktop-services} and
 provided by @code{(gnu services dbus)} and @code{(gnu services desktop)}
 are described below.
 
-@deffn {Scheme Procedure} dbus-service [#:dbus @var{dbus}] [#:services '()]
+@deffn {Scheme Procedure} dbus-service [#:dbus @var{dbus}] [#:services '()] @
+                                       [#:verbose?]
 Return a service that runs the ``system bus'', using @var{dbus}, with
-support for @var{services}.
+support for @var{services}.  When @var{verbose?} is true, it causes the
+@samp{DBUS_VERBOSE} environment variable to be set to @samp{1}; a
+verbose-enabled D-Bus package such as @code{dbus-verbose} should be
+provided as @var{dbus} in this scenario.  The verbose output is logged
+to @file{/var/log/dbus-daemon.log}.
 
 @uref{https://dbus.freedesktop.org/, D-Bus} is an inter-process communication
 facility.  Its system bus is used to allow system services to communicate
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 85a4c3ec9a..da167f2e36 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -53,7 +53,9 @@ (define-record-type* <dbus-configuration>
   (dbus      dbus-configuration-dbus              ;file-like
              (default dbus))
   (services  dbus-configuration-services          ;list of <package>
-             (default '())))
+             (default '()))
+  (verbose?  dbus-configuration-verbose?          ;boolean
+             (default #f)))
 
 (define (system-service-directory services)
   "Return the system service directory, containing @code{.service} files for
@@ -187,7 +189,7 @@ (define (dbus-activation config)
 
 (define dbus-shepherd-service
   (match-lambda
-    (($ <dbus-configuration> dbus)
+    (($ <dbus-configuration> dbus _ verbose?)
      (list (shepherd-service
             (documentation "Run the D-Bus system daemon.")
             (provision '(dbus-system))
@@ -195,6 +197,10 @@ (define dbus-shepherd-service
             (start #~(make-forkexec-constructor
                       (list (string-append #$dbus "/bin/dbus-daemon")
                             "--nofork" "--system" "--syslog-only")
+                      #$@(if verbose?
+                             '(#:environment-variables '("DBUS_VERBOSE=1")
+                               #:log-file "/var/log/dbus-daemon.log")
+                             '())
                       #:pid-file "/var/run/dbus/pid"))
             (stop #~(make-kill-destructor)))))))
 
@@ -230,9 +236,12 @@ (define dbus-root-service-type
 bus.  It allows programs and daemons to communicate and is also responsible
 for spawning (@dfn{activating}) D-Bus services on demand.")))
 
-(define* (dbus-service #:key (dbus dbus) (services '()))
+(define* (dbus-service #:key (dbus dbus) (services '()) verbose?)
   "Return a service that runs the \"system bus\", using @var{dbus}, with
-support for @var{services}.
+support for @var{services}.  When @var{verbose?} is true, it causes the
+@samp{DBUS_VERBOSE} environment variable to be set to @samp{1}; a
+verbose-enabled D-Bus package such as @code{dbus-verbose} should be provided
+as @var{dbus} in this scenario.
 
 @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication
 facility.  Its system bus is used to allow system services to communicate and
@@ -244,7 +253,8 @@ (define* (dbus-service #:key (dbus dbus) (services '()))
 @var{services} must be equal to @code{(list avahi)}."
   (service dbus-root-service-type
            (dbus-configuration (dbus dbus)
-                               (services services))))
+                               (services services)
+                               (verbose? verbose?))))
 
 (define (wrapped-dbus-service service program variables)
   "Return a wrapper for @var{service}, a package containing a D-Bus service,
-- 
2.34.0

>From 31da8e84df7cdeb2084d4bf17c51208d7ad171db Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <[email-masked]>
Date: Wed, 8 Dec 2021 16:19:27 -0500
Subject: [PATCH 3/5] build: Move D-Bus parser to its own build module.

* gnu/build/jami-service.scm (with-retries, parse-dbus-reply)
(strip-quotes, deserialize-item, serialize-boolean, dict->alist)
(array->list, %send-dbus-binary, %send-dbus-bus, %send-dbus-user)
(%send-dbus-group, %send-dbus-debug, send-dbus, dbus-available-services)
(dbus-service-available?): Move to ...
* gnu/build/dbus-service.scm: ... this new module, prefixing 'dbus-' to
dict->alist and array->list in the process.
* gnu/local.mk (GNU_SYSTEM_MODULES): Register new module.
* gnu/services/telephony.scm: Adjust.
* gnu/tests/telephony.scm: Likewise.
---
 gnu/build/dbus-service.scm | 248 +++++++++++++++++++++++++++++++++++++
 gnu/build/jami-service.scm | 209 +------------------------------
 gnu/local.mk               |   1 +
 gnu/services/telephony.scm |   5 +-
 gnu/tests/telephony.scm    |   2 +
 5 files changed, 261 insertions(+), 204 deletions(-)
 create mode 100644 gnu/build/dbus-service.scm

diff --git a/gnu/build/dbus-service.scm b/gnu/build/dbus-service.scm
new file mode 100644
index 0000000000..fd56c8dae7
--- /dev/null
+++ b/gnu/build/dbus-service.scm
@@ -0,0 +1,248 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxim Cournoyer <[email-masked]>
+;;;
+;;; 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/>.
+
+;;; Commentary:
+;;;
+;;; This module contains procedures to interact with D-Bus via the 'dbus-send'
+;;; command line utility.
+;;;
+;;; Code:
+
+(define-module (gnu build dbus-service)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 peg)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:autoload (shepherd service) (fork+exec-command)
+  #:export (%send-dbus-binary
+            %send-dbus-bus
+            %send-dbus-user
+            %send-dbus-group
+            %send-dbus-debug
+            send-dbus
+
+            parse-dbus-reply
+            deserialize-item
+            serialize-boolean
+            dbus-dict->alist
+            dbus-array->list
+
+            dbus-available-services
+            dbus-service-available?
+
+            with-retries))
+
+;;;
+;;; Utilities.
+;;;
+
+(define-syntax-rule (with-retries n delay body ...)
+  "Retry the code in BODY up to N times until it doesn't raise an exception
+nor return #f, else raise an error.  A delay of DELAY seconds is inserted
+before each retry."
+  (let loop ((attempts 0))
+    (catch #t
+      (lambda ()
+        (let ((result (begin body ...)))
+          (if (not result)
+              (error "failed attempt" attempts)
+              result)))
+      (lambda args
+        (if (< attempts n)
+            (begin
+              (sleep delay)             ;else wait and retry
+              (loop (+ 1 attempts)))
+            (error "maximum number of retry attempts reached"
+                   body ... args))))))
+
+
+;;;
+;;; D-Bus reply parser.
+;;;
+
+(define (parse-dbus-reply reply)
+  "Return the parse tree of REPLY, a string returned by the 'dbus-send'
+command."
+  ;; Refer to 'man 1 dbus-send' for the grammar reference.  Note that the
+  ;; format of the replies doesn't match the format of the input, which is the
+  ;; one documented, but it gives an idea.  For an even better reference, see
+  ;; the `print_iter' procedure of the 'dbus-print-message.c' file from the
+  ;; 'dbus' package sources.
+  (define-peg-string-patterns
+    "contents <- header (item / container (item / container*)?)
+     item <-- WS type WS value NL
+     container <- array / dict / variant
+     array <-- array-start (item / container)* array-end
+     dict <-- array-start dict-entry* array-end
+     dict-entry <-- dict-entry-start item item dict-entry-end
+     variant <-- variant-start item
+     type <-- 'string' / 'int16' / 'uint16' / 'int32' / 'uint32' / 'int64' /
+              'uint64' / 'double' / 'byte' / 'boolean' / 'objpath'
+     value <-- (!NL .)* NL
+     header < (!NL .)* NL
+     variant-start < WS 'variant'
+     array-start < WS 'array [' NL
+     array-end < WS ']' NL
+     dict-entry-start < WS 'dict entry(' NL
+     dict-entry-end < WS ')' NL
+     DQ < '\"'
+     WS < ' '*
+     NL < '\n'*")
+
+  (peg:tree (match-pattern contents reply)))
+
+(define (strip-quotes text)
+  "Strip the leading and trailing double quotes (\") characters from TEXT."
+  (let* ((text* (if (string-prefix? "\"" text)
+                    (string-drop text 1)
+                    text))
+         (text** (if (string-suffix? "\"" text*)
+                     (string-drop-right text* 1)
+                     text*)))
+    text**))
+
+(define (deserialize-item item)
+  "Return the value described by the ITEM parse tree as a Guile object."
+  ;; Strings are printed wrapped in double quotes (see the print_iter
+  ;; procedure in dbus-print-message.c).
+  (match item
+    (('item ('type "string") ('value value))
+     (strip-quotes value))
+    (('item ('type "boolean") ('value value))
+     (if (string=? "true" value)
+         #t
+         #f))
+    (('item _ ('value value))
+     value)))
+
+(define (serialize-boolean bool)
+  "Return the serialized format expected by dbus-send for BOOL."
+  (format #f "boolean:~:[false~;true~]" bool))
+
+(define (dbus-dict->alist dict-parse-tree)
+  "Translate a dict parse tree to an alist."
+  (define (tuples->alist tuples)
+    (map (lambda (x) (apply cons x)) tuples))
+
+  (match dict-parse-tree
+    ('dict
+     '())
+    (('dict ('dict-entry keys values) ...)
+     (let ((keys* (map deserialize-item keys))
+           (values* (map deserialize-item values)))
+       (tuples->alist (zip keys* values*))))))
+
+;;;
+(define (dbus-array->list array-parse-tree)
+  "Translate an array parse tree to a list."
+  (match array-parse-tree
+    ('array
+     '())
+    (('array items ...)
+     (map deserialize-item items))))
+
+
+;;;
+;;; Low-level, D-Bus-related procedures.
+;;;
+
+;;; The following parameters are used in the jami-service-type service
+;;; definition to conveniently customize the behavior of the send-dbus helper,
+;;; even when called indirectly.
+(define %send-dbus-binary (make-parameter "dbus-send"))
+(define %send-dbus-bus (make-parameter #f))
+(define %send-dbus-user (make-parameter #f))
+(define %send-dbus-group (make-parameter #f))
+(define %send-dbus-debug (make-parameter #f))
+
+(define* (send-dbus #:key service path interface method
+                    bus
+                    dbus-send
+                    user group
+                    timeout
+                    arguments)
+  "Return the response of DBUS-SEND, else raise an error.  Unless explicitly
+provided, DBUS-SEND takes the value of the %SEND-DBUS-BINARY parameter.  BUS
+can be used to specify the bus address, such as 'unix:path=/var/run/jami/bus'.
+Alternatively, the %SEND-DBUS-BUS parameter can be used.  ARGUMENTS can be
+used to pass input values to a D-Bus method call.  TIMEOUT is the amount of
+time to wait for a reply in milliseconds before giving up with an error.  USER
+and GROUP allow choosing under which user/group the DBUS-SEND command is
+executed.  Alternatively, the %SEND-DBUS-USER and %SEND-DBUS-GROUP parameters
+can be used instead."
+  (let* ((command `(,(if dbus-send
+                         dbus-send
+                         (%send-dbus-binary))
+                    ,@(if (or bus (%send-dbus-bus))
+                          (list (string-append "--bus="
+                                               (or bus (%send-dbus-bus))))
+                          '())
+                    "--print-reply"
+                    ,@(if timeout
+                          (list (format #f "--reply-timeout=~d" timeout))
+                          '())
+                    ,(string-append "--dest=" service) ;e.g., cx.ring.Ring
+                    ,path            ;e.g., /cx/ring/Ring/ConfigurationManager
+                    ,(string-append interface "." method)
+                    ,@(or arguments '())))
+         (temp-port (mkstemp! (string-copy "/tmp/dbus-send-output-XXXXXXX")))
+         (temp-file (port-filename temp-port)))
+    (dynamic-wind
+      (lambda ()
+        (let* ((uid (or (and=> (or user (%send-dbus-user))
+                               (compose passwd:uid getpwnam)) -1))
+               (gid (or (and=> (or group (%send-dbus-group))
+                               (compose group:gid getgrnam)) -1)))
+          (chown temp-port uid gid)))
+      (lambda ()
+        (let ((pid (fork+exec-command command
+                                      #:user (or user (%send-dbus-user))
+                                      #:group (or group (%send-dbus-group))
+                                      #:log-file temp-file)))
+          (match (waitpid pid)
+            ((_ . status)
+             (let ((exit-status (status:exit-val status))
+                   (output (call-with-port temp-port get-string-all)))
+               (if (= 0 exit-status)
+                   output
+                   (error "the send-dbus command exited with: "
+                          command exit-status output)))))))
+      (lambda ()
+        (false-if-exception (delete-file temp-file))))))
+
+
+;;;
+;;; Higher-level, D-Bus-related procedures.
+;;;
+
+(define (dbus-available-services)
+  "Return the list of available (acquired) D-Bus services."
+  (let ((reply (parse-dbus-reply
+                (send-dbus #:service "org.freedesktop.DBus"
+                           #:path "/org/freedesktop/DBus"
+                           #:interface "org.freedesktop.DBus"
+                           #:method "ListNames"))))
+    ;; Remove entries such as ":1.7".
+    (remove (cut string-prefix? ":" <>)
+            (dbus-array->list reply))))
+
+(define (dbus-service-available? service)
+  "Predicate to check for the D-Bus SERVICE availability."
+  (member service (dbus-available-services)))
diff --git a/gnu/build/jami-service.scm b/gnu/build/jami-service.scm
index ddfc8cf937..f8c392d3e5 100644
--- a/gnu/build/jami-service.scm
+++ b/gnu/build/jami-service.scm
@@ -24,13 +24,11 @@
 ;;; Code:
 
 (define-module (gnu build jami-service)
+  #:use-module (gnu build dbus-service)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 peg)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
-  #:use-module (rnrs io ports)
-  #:autoload (shepherd service) (fork+exec-command)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (account-fingerprint?
@@ -51,43 +49,12 @@ (define-module (gnu build jami-service)
             set-all-moderators
             set-moderator
             username->all-moderators?
-            username->moderators
-
-            dbus-available-services
-            dbus-service-available?
-
-            %send-dbus-binary
-            %send-dbus-bus
-            %send-dbus-user
-            %send-dbus-group
-            %send-dbus-debug
-            send-dbus
-
-            with-retries))
+            username->moderators))
 
 ;;;
 ;;; Utilities.
 ;;;
 
-(define-syntax-rule (with-retries n delay body ...)
-  "Retry the code in BODY up to N times until it doesn't raise an exception
-nor return #f, else raise an error.  A delay of DELAY seconds is inserted
-before each retry."
-  (let loop ((attempts 0))
-    (catch #t
-      (lambda ()
-        (let ((result (begin body ...)))
-          (if (not result)
-              (error "failed attempt" attempts)
-              result)))
-      (lambda args
-        (if (< attempts n)
-            (begin
-              (sleep delay)             ;else wait and retry
-              (loop (+ 1 attempts)))
-            (error "maximum number of retry attempts reached"
-                   body ... args))))))
-
 (define (alist->list alist)
   "Flatten ALIST into a list."
   (append-map (match-lambda
@@ -104,169 +71,20 @@ (define (account-fingerprint? val)
   (and (string? val)
        (regexp-exec account-fingerprint-rx val)))
 
-
-;;;
-;;; D-Bus reply parser.
-;;;
-
-(define (parse-dbus-reply reply)
-  "Return the parse tree of REPLY, a string returned by the 'dbus-send'
-command."
-  ;; Refer to 'man 1 dbus-send' for the grammar reference.  Note that the
-  ;; format of the replies doesn't match the format of the input, which is the
-  ;; one documented, but it gives an idea.  For an even better reference, see
-  ;; the `print_iter' procedure of the 'dbus-print-message.c' file from the
-  ;; 'dbus' package sources.
-  (define-peg-string-patterns
-    "contents <- header (item / container (item / container*)?)
-     item <-- WS type WS value NL
-     container <- array / dict / variant
-     array <-- array-start (item / container)* array-end
-     dict <-- array-start dict-entry* array-end
-     dict-entry <-- dict-entry-start item item dict-entry-end
-     variant <-- variant-start item
-     type <-- 'string' / 'int16' / 'uint16' / 'int32' / 'uint32' / 'int64' /
-              'uint64' / 'double' / 'byte' / 'boolean' / 'objpath'
-     value <-- (!NL .)* NL
-     header < (!NL .)* NL
-     variant-start < WS 'variant'
-     array-start < WS 'array [' NL
-     array-end < WS ']' NL
-     dict-entry-start < WS 'dict entry(' NL
-     dict-entry-end < WS ')' NL
-     DQ < '\"'
-     WS < ' '*
-     NL < '\n'*")
-
-  (peg:tree (match-pattern contents reply)))
-
-(define (strip-quotes text)
-  "Strip the leading and trailing double quotes (\") characters from TEXT."
-  (let* ((text* (if (string-prefix? "\"" text)
-                    (string-drop text 1)
-                    text))
-         (text** (if (string-suffix? "\"" text*)
-                     (string-drop-right text* 1)
-                     text*)))
-    text**))
-
-(define (deserialize-item item)
-  "Return the value described by the ITEM parse tree as a Guile object."
-  ;; Strings are printed wrapped in double quotes (see the print_iter
-  ;; procedure in dbus-print-message.c).
-  (match item
-    (('item ('type "string") ('value value))
-     (strip-quotes value))
-    (('item ('type "boolean") ('value value))
-     (if (string=? "true" value)
-         #t
-         #f))
-    (('item _ ('value value))
-     value)))
-
-(define (serialize-boolean bool)
-  "Return the serialized format expected by dbus-send for BOOL."
-  (format #f "boolean:~:[false~;true~]" bool))
-
-(define (dict->alist dict-parse-tree)
-  "Translate a dict parse tree to an alist."
-  (define (tuples->alist tuples)
-    (map (lambda (x) (apply cons x)) tuples))
-
-  (match dict-parse-tree
-    ('dict
-     '())
-    (('dict ('dict-entry keys values) ...)
-     (let ((keys* (map deserialize-item keys))
-           (values* (map deserialize-item values)))
-       (tuples->alist (zip keys* values*))))))
-
-(define (array->list array-parse-tree)
-  "Translate an array parse tree to a list."
-  (match array-parse-tree
-    ('array
-     '())
-    (('array items ...)
-     (map deserialize-item items))))
-
 
 ;;;
 ;;; Low-level, D-Bus-related procedures.
 ;;;
 
-;;; The following parameters are used in the jami-service-type service
-;;; definition to conveniently customize the behavior of the send-dbus helper,
-;;; even when called indirectly.
-(define %send-dbus-binary (make-parameter "dbus-send"))
-(define %send-dbus-bus (make-parameter #f))
-(define %send-dbus-user (make-parameter #f))
-(define %send-dbus-group (make-parameter #f))
-(define %send-dbus-debug (make-parameter #f))
-
-(define* (send-dbus #:key service path interface method
-                    bus
-                    dbus-send
-                    user group
-                    timeout
-                    arguments)
-  "Return the response of DBUS-SEND, else raise an error.  Unless explicitly
-provided, DBUS-SEND takes the value of the %SEND-DBUS-BINARY parameter.  BUS
-can be used to specify the bus address, such as 'unix:path=/var/run/jami/bus'.
-Alternatively, the %SEND-DBUS-BUS parameter can be used.  ARGUMENTS can be
-used to pass input values to a D-Bus method call.  TIMEOUT is the amount of
-time to wait for a reply in milliseconds before giving up with an error.  USER
-and GROUP allow choosing under which user/group the DBUS-SEND command is
-executed.  Alternatively, the %SEND-DBUS-USER and %SEND-DBUS-GROUP parameters
-can be used instead."
-  (let* ((command `(,(if dbus-send
-                         dbus-send
-                         (%send-dbus-binary))
-                    ,@(if (or bus (%send-dbus-bus))
-                          (list (string-append "--bus="
-                                               (or bus (%send-dbus-bus))))
-                          '())
-                    "--print-reply"
-                    ,@(if timeout
-                          (list (format #f "--reply-timeout=~d" timeout))
-                          '())
-                    ,(string-append "--dest=" service) ;e.g., cx.ring.Ring
-                    ,path            ;e.g., /cx/ring/Ring/ConfigurationManager
-                    ,(string-append interface "." method)
-                    ,@(or arguments '())))
-         (temp-port (mkstemp! (string-copy "/tmp/dbus-send-output-XXXXXXX")))
-         (temp-file (port-filename temp-port)))
-    (dynamic-wind
-      (lambda ()
-        (let* ((uid (or (and=> (or user (%send-dbus-user))
-                               (compose passwd:uid getpwnam)) -1))
-               (gid (or (and=> (or group (%send-dbus-group))
-                               (compose group:gid getgrnam)) -1)))
-          (chown temp-port uid gid)))
-      (lambda ()
-        (let ((pid (fork+exec-command command
-                                      #:user (or user (%send-dbus-user))
-                                      #:group (or group (%send-dbus-group))
-                                      #:log-file temp-file)))
-          (match (waitpid pid)
-            ((_ . status)
-             (let ((exit-status (status:exit-val status))
-                   (output (call-with-port temp-port get-string-all)))
-               (if (= 0 exit-status)
-                   output
-                   (error "the send-dbus command exited with: "
-                          command exit-status output)))))))
-      (lambda ()
-        (false-if-exception (delete-file temp-file))))))
-
 (define (parse-account-ids reply)
   "Return the Jami account IDs from REPLY, which is assumed to be the output
 of the Jami D-Bus `getAccountList' method."
-  (array->list (parse-dbus-reply reply)))
+  (dbus-array->list (parse-dbus-reply reply)))
 
 (define (parse-account-details reply)
   "Parse REPLY, which is assumed to be the output of the Jami D-Bus
 `getAccountDetails' method, and return its content as an alist."
-  (dict->alist (parse-dbus-reply reply)))
+  (dbus-dict->alist (parse-dbus-reply reply)))
 
 (define (parse-contacts reply)
   "Parse REPLY, which is assumed to be the output of the Jamid D-Bus
@@ -275,7 +93,7 @@ (define (parse-contacts reply)
     ('array
      '())
     (('array dicts ...)
-     (map dict->alist dicts))))
+     (map dbus-dict->alist dicts))))
 
 
 ;;;
@@ -287,21 +105,6 @@ (define (validate-fingerprint fingerprint)
   (unless (account-fingerprint? fingerprint)
     (error "Account fingerprint is not valid:" fingerprint)))
 
-(define (dbus-available-services)
-  "Return the list of available (acquired) D-Bus services."
-  (let ((reply (parse-dbus-reply
-                (send-dbus #:service "org.freedesktop.DBus"
-                           #:path "/org/freedesktop/DBus"
-                           #:interface "org.freedesktop.DBus"
-                           #:method "ListNames"))))
-    ;; Remove entries such as ":1.7".
-    (remove (cut string-prefix? ":" <>)
-            (array->list reply))))
-
-(define (dbus-service-available? service)
-  "Predicate to check for the D-Bus SERVICE availability."
-  (member service (dbus-available-services)))
-
 (define* (send-dbus/configuration-manager #:key method arguments timeout)
   "Query the Jami D-Bus ConfigurationManager service."
   (send-dbus #:service "cx.ring.Ring"
@@ -522,7 +325,7 @@ (define (username->moderators username)
                  #:method "getDefaultModerators"
                  #:arguments
                  (list (string-append "string:" id)))))
-    (array->list (parse-dbus-reply reply))))
+    (dbus-array->list (parse-dbus-reply reply))))
 
 (define (set-moderator contact enabled? username)
   "Set the moderator flag to ENABLED? for CONTACT, the 40 characters public
diff --git a/gnu/local.mk b/gnu/local.mk
index 5c19919f2e..55c5536450 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -706,6 +706,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/build/bootloader.scm			\
   %D%/build/chromium-extension.scm		\
   %D%/build/cross-toolchain.scm			\
+  %D%/build/dbus-service.scm			\
   %D%/build/image.scm				\
   %D%/build/jami-service.scm			\
   %D%/build/file-systems.scm			\
diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm
index 7c83f13b2a..f6501b6423 100644
--- a/gnu/services/telephony.scm
+++ b/gnu/services/telephony.scm
@@ -296,7 +296,8 @@ (define (jami-shepherd-services config)
          (declarative-mode? (not (eq? 'disabled accounts))))
 
     (with-imported-modules (source-module-closure
-                            '((gnu build jami-service)
+                            '((gnu build dbus-service)
+                              (gnu build jami-service)
                               (gnu build shepherd)
                               (gnu system file-systems)))
 
@@ -515,6 +516,7 @@ (define disable-account-action
              (documentation "Run a D-Bus session for the Jami daemon.")
              (provision '(jami-dbus-session))
              (modules `((gnu build shepherd)
+                        (gnu build dbus-service)
                         (gnu build jami-service)
                         (gnu system file-systems)
                         ,@%default-modules))
@@ -579,6 +581,7 @@ (define pid
                         (ice-9 receive)
                         (srfi srfi-1)
                         (srfi srfi-26)
+                        (gnu build dbus-service)
                         (gnu build jami-service)
                         (gnu build shepherd)
                         (gnu system file-systems)
diff --git a/gnu/tests/telephony.scm b/gnu/tests/telephony.scm
index 998bdbccf9..3b0a458c75 100644
--- a/gnu/tests/telephony.scm
+++ b/gnu/tests/telephony.scm
@@ -127,12 +127,14 @@ (define username (assoc-ref %jami-account-content-sexp
   (define test
     (with-imported-modules (source-module-closure
                             '((gnu build marionette)
+                              (gnu build dbus-service)
                               (gnu build jami-service)))
       #~(begin
           (use-modules (rnrs base)
                        (srfi srfi-11)
                        (srfi srfi-64)
                        (gnu build marionette)
+                       (gnu build dbus-service)
                        (gnu build jami-service))
 
           (define marionette
-- 
2.34.0

>From 2b6624568622a409804a52cedcc2f7c15c420112 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <[email-masked]>
Date: Wed, 8 Dec 2021 17:25:11 -0500
Subject: [PATCH 4/5] services: telephony: Factorize bus polling logic.

* gnu/services/telephony.scm (jami-shepherd-services): Move bus readiness
polling logic to...
* gnu/build/dbus-service.scm (wait-for-bus-readiness): ... here.
(%dbus-system-bus): New variable.
* gnu/packages/freedesktop.scm (localed): Use it.
---
 gnu/build/dbus-service.scm   | 20 +++++++++++++++++++-
 gnu/packages/freedesktop.scm |  8 ++++----
 gnu/services/telephony.scm   | 10 +---------
 3 files changed, 24 insertions(+), 14 deletions(-)

diff --git a/gnu/build/dbus-service.scm b/gnu/build/dbus-service.scm
index fd56c8dae7..3ffdebc04d 100644
--- a/gnu/build/dbus-service.scm
+++ b/gnu/build/dbus-service.scm
@@ -31,7 +31,9 @@ (define-module (gnu build dbus-service)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:autoload (shepherd service) (fork+exec-command)
-  #:export (%send-dbus-binary
+  #:export (%dbus-system-bus
+
+            %send-dbus-binary
             %send-dbus-bus
             %send-dbus-user
             %send-dbus-group
@@ -44,11 +46,14 @@ (define-module (gnu build dbus-service)
             dbus-dict->alist
             dbus-array->list
 
+            wait-for-bus-readiness
             dbus-available-services
             dbus-service-available?
 
             with-retries))
 
+(define %dbus-system-bus "/var/run/dbus/system_bus_socket")
+
 ;;;
 ;;; Utilities.
 ;;;
@@ -232,6 +237,19 @@ (define* (send-dbus #:key service path interface method
 ;;; Higher-level, D-Bus-related procedures.
 ;;;
 
+(define* (wait-for-bus-readiness #:key (bus %dbus-system-bus)
+                                 (timeout 25))
+  "Wait until a connection can be opened to BUS.  An error is raised when
+TIMEOUT seconds elapse."
+  (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
+    (with-retries timeout 1 (catch 'system-error
+                              (lambda ()
+                                (connect sock AF_UNIX bus)
+                                (close-port sock)
+                                #t)
+                              (lambda args
+                                #f)))))
+
 (define (dbus-available-services)
   "Return the list of available (acquired) D-Bus services."
   (let ((reply (parse-dbus-reply
diff --git a/gnu/packages/freedesktop.scm b/gnu/packages/freedesktop.scm
index eba06600b2..5f9cbd8438 100644
--- a/gnu/packages/freedesktop.scm
+++ b/gnu/packages/freedesktop.scm
@@ -57,6 +57,7 @@ (define-module (gnu packages freedesktop)
   #:use-module (guix build-system perl)
   #:use-module (guix build-system python)
   #:use-module (guix build-system glib-or-gtk)
+  #:use-module ((gnu build dbus-service) #:select (%dbus-system-bus))
   #:use-module (gnu packages)
   #:use-module (gnu packages acl)
   #:use-module (gnu packages admin)
@@ -730,20 +731,19 @@ (define-public localed
               (file-name (git-file-name name version))
               (modules '((guix build utils)))
               (snippet
-               '(begin
+               `(begin
                   ;; Connect to the right location for our D-Bus daemon.
                   (substitute* '("src/basic/def.h"
                                  "src/libsystemd/sd-bus/sd-bus.c"
                                  "src/stdio-bridge/stdio-bridge.c")
                     (("/run/dbus/system_bus_socket")
-                     "/var/run/dbus/system_bus_socket"))
+                     ,%dbus-system-bus))
 
                   ;; Don't insist on having systemd as PID 1 (otherwise
                   ;; 'localectl' would exit without doing anything.)
                   (substitute* "src/shared/bus-util.c"
                     (("sd_booted\\(\\)")
-                     "(1)"))
-                  #t))
+                     "(1)"))))
               (patches (search-patches "localed-xorg-keyboard.patch"))))
     (build-system meson-build-system)
     (arguments
diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm
index f6501b6423..0ceebbc6d6 100644
--- a/gnu/services/telephony.scm
+++ b/gnu/services/telephony.scm
@@ -549,15 +549,7 @@ (define pid
                   ;; needed if we were using a PID file, but providing it via a
                   ;; customized config file with <pidfile> would not override
                   ;; the one inherited from the base config of D-Bus.
-                  (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
-                    (with-retries 20 1 (catch 'system-error
-                                         (lambda ()
-                                           (connect sock AF_UNIX
-                                                    "/var/run/jami/bus")
-                                           (close-port sock)
-                                           #t)
-                                         (lambda args
-                                           #f))))
+                  (wait-for-bus-readiness #:bus "/var/run/jami/bus")
 
                   pid))
              (stop #~(make-kill-destructor)))
-- 
2.34.0

>From ee0e5d34a0ad5f52c547fdd7d270ab451eccab4a Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <[email-masked]>
Date: Thu, 9 Dec 2021 23:53:12 -0500
Subject: [PATCH 5/5] services: dbus: Add synchronization primitives to dbus,
 elogind.

This is an (unsuccessful) to fix https://issues.guix.gnu.org/52051.
---
 gnu/services/dbus.scm    | 28 ++++++++++++++++++++--------
 gnu/services/desktop.scm | 35 +++++++++++++++++++++++++++--------
 2 files changed, 47 insertions(+), 16 deletions(-)

diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index da167f2e36..c285531663 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -194,14 +194,26 @@ (define dbus-shepherd-service
             (documentation "Run the D-Bus system daemon.")
             (provision '(dbus-system))
             (requirement '(user-processes syslogd))
-            (start #~(make-forkexec-constructor
-                      (list (string-append #$dbus "/bin/dbus-daemon")
-                            "--nofork" "--system" "--syslog-only")
-                      #$@(if verbose?
-                             '(#:environment-variables '("DBUS_VERBOSE=1")
-                               #:log-file "/var/log/dbus-daemon.log")
-                             '())
-                      #:pid-file "/var/run/dbus/pid"))
+            (modules `((gnu build dbus-service)
+                       ,@%default-modules))
+            (start
+             (with-imported-modules '((gnu build dbus-service))
+               #~(lambda args
+                   (define pid
+                     ((make-forkexec-constructor
+                       (list (string-append #$dbus "/bin/dbus-daemon")
+                             "--nofork" "--system" "--syslog-only")
+                       #$@(if verbose?
+                              ;; Since the verbose output goes to the console,
+                              ;; not syslog, add a log file to capture it.
+                              '(#:environment-variables '("DBUS_VERBOSE=1")
+                                #:log-file "/var/log/dbus-daemon.log")
+                              '())
+                       #:pid-file "/var/run/dbus/pid")))
+                   ;; Ensure the system bus is ready to service requests
+                   ;; before returning.
+                   (wait-for-bus-readiness)
+                   pid)))
             (stop #~(make-kill-destructor)))))))
 
 (define dbus-root-service-type
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index 612d548eea..3208cb7aac 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -3,7 +3,7 @@
 ;;; Copyright © 2015 Andy Wingo <[email-masked]>
 ;;; Copyright © 2015 Mark H Weaver <[email-masked]>
 ;;; Copyright © 2016 Sou Bunnbu <[email-masked]>
-;;; Copyright © 2017, 2020 Maxim Cournoyer <[email-masked]>
+;;; Copyright © 2017, 2020, 2021 Maxim Cournoyer <[email-masked]>
 ;;; Copyright © 2017 Nikita <[email-masked]>
 ;;; Copyright © 2018, 2020 Efraim Flashner <[email-masked]>
 ;;; Copyright © 2018 Ricardo Wurmus <[email-masked]>
@@ -724,13 +724,32 @@ (define (elogind-shepherd-service config)
   (list (shepherd-service
          (requirement '(dbus-system))
          (provision '(elogind))
-         (start #~(make-forkexec-constructor
-                   (list #$(file-append (elogind-package config)
-                                        "/libexec/elogind/elogind"))
-                   #:environment-variables
-                   (list (string-append "ELOGIND_CONF_FILE="
-                                        #$(elogind-configuration-file
-                                           config)))))
+         (modules `((gnu build dbus-service)
+                    ,@%default-modules))
+         (start
+          (with-imported-modules '((gnu build dbus-service))
+            #~(lambda args
+                (define pid
+                  ((make-forkexec-constructor
+                    (list #$(file-append strace "/bin/strace") "-f"
+                          "-o/elogind.log" "-s700"
+                          #$(file-append (elogind-package config)
+                                         "/libexec/elogind/elogind"))
+                    #:environment-variables
+                    (list (string-append "ELOGIND_CONF_FILE="
+                                         #$(elogind-configuration-file
+                                            config))))))
+                ;; Wait until the login1 service name has been acquired by
+                ;; D-Bus.  This prevents potential races that would cause
+                ;; elogind to be auto started by D-Bus by other processes
+                ;; requiring it, causing problems.
+                (parameterize ((%send-dbus-bus (string-append "unix:path="
+                                                              %dbus-system-bus)))
+                  (with-retries 25 1
+                    (pk 'available-dbus-services (dbus-available-services))
+                    (dbus-service-available? "org.freedesktop.login1")))
+
+                pid)))
          (stop #~(make-kill-destructor)))))
 
 (define elogind-service-type
-- 
2.34.0

> static dbus_bool_t
> handle_new_client_fd_and_unlock (DBusServer *server,
>                                  DBusSocket  client_fd)
> {
>
> [...]
>
>   /* See if someone wants to handle this new connection, self-referencing
>    * for paranoia.
>    */
>   new_connection_function = server->new_connection_function;
>   new_connection_data = server->new_connection_data;
>
>   _dbus_server_ref_unlocked (server);
>   SERVER_UNLOCK (server);
>
>   if (new_connection_function)
>     {
>       (* new_connection_function) (server, connection,
>                                    new_connection_data);
>     }
>   dbus_server_unref (server);
>
>   /* If no one grabbed a reference, the connection will die. */
>   _dbus_connection_close_if_only_one_ref (connection);
>   dbus_connection_unref (connection);
>
> We know that elogind is started after dbus-daemon has written its PID
> file (there’s a Shepherd service dependency).  Is there a possibility
> that dbus-daemon writes its PID file before it has set
> ‘new_connection_function’?

Are PID files conventionally agreed to be synchronization primitives?
In the case of systemd, I feel this may be more of an afterthought,
given the system is designed to rely on socket-based activation.  Still
just guessing though, and your analysis above seems to suggest
otherwise.

> It would seem that ‘bus_context_new’ writes the PID file after it has
> called ‘dbus_server_set_new_connection_function’ via ‘setup_server’ via
> ‘process_config_first_time_only’.
>
> So not sure what happens.
>
> That’s it for today.  Thoughts?

Thank you!

I'm sorry for my lack of deep analysis here, I've spent most of my
evening attempting to fix my system just to boot ^^'.  I've at least
managed to collect the following verbose D-Bus log (54 MiB uncompressed)
which hopefully can shed some light onto how this failure came to be.

Happy Friday!

Maxim