;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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.  Before using any public procedure
;;;
;;; Code:

(define-module (gnu build dbus-service)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-mo</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=4b9b1ec787dd98c51e5b7e179845702a455c47a4'>refs</a><a href='/guix/log/gnu/system/vm.scm'>log</a><a href='/guix/tree/gnu/system/vm.scm?id=4b9b1ec787dd98c51e5b7e179845702a455c47a4'>tree</a><a href='/guix/commit/gnu/system/vm.scm?id=4b9b1ec787dd98c51e5b7e179845702a455c47a4'>commit</a><a class='active' href='/guix/diff/gnu/system/vm.scm?id=4b9b1ec787dd98c51e5b7e179845702a455c47a4&amp;id2=134bb86990aa20aa96456de0c0265c4791f76725'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/gnu/system/vm.scm'>
<input type='hidden' name='id' value='4b9b1ec787dd98c51e5b7e179845702a455c47a4'/><input type='hidden' name='id2' value='134bb86990aa20aa96456de0c0265c4791f76725'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/diff/?id=4b9b1ec787dd98c51e5b7e179845702a455c47a4&amp;id2=134bb86990aa20aa96456de0c0265c4791f76725'>root</a>/<a href='/guix/diff/gnu?id=4b9b1ec787dd98c51e5b7e179845702a455c47a4&amp;id2=134bb86990aa20aa96456de0c0265c4791f76725'>gnu</a>/<a href='/guix/diff/gnu/system?id=4b9b1ec787dd98c51e5b7e179845702a455c47a4&amp;id2=134bb86990aa20aa96456de0c0265c4791f76725'>system</a>/<a href='/guix/diff/gnu/system/vm.scm?id=4b9b1ec787dd98c51e5b7e179845702a455c47a4&amp;id2=134bb86990aa20aa96456de0c0265c4791f76725'>vm.scm</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='4b9b1ec787dd98c51e5b7e179845702a455c47a4'/><input type='hidden' name='id2' value='134bb86990aa20aa96456de0c0265c4791f76725'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><div class='diffstat-header'><a href='/guix/diff/?id=4b9b1ec787dd98c51e5b7e179845702a455c47a4&amp;id2=134bb86990aa20aa96456de0c0265c4791f76725'>Diffstat</a> (limited to 'gnu/system/vm.scm')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
y contains a single element, it is returned directly, else the body
elements are returned as a list.  TIMEOUT is a timeout value in seconds."
  (let ((serial     (d-bus-write-message connection message))
        (start-time (current-time time-monotonic))
        (timeout* (or timeout %dbus-query-timeout)))
    (d-bus-conn-flush connection)
    (let retry ()
      (when (> (time-second (time-difference (current-time time-monotonic)
                                             start-time))
               timeout*)
        (error 'dbus "fail to get reply in timeout" timeout*))
      (let* ((reply (d-bus-read-message connection))
             (reply-headers (d-bus-message-headers reply))
             (reply-serial (d-bus-headers-ref reply-headers 'REPLY_SERIAL))
             (error-name (d-bus-headers-ref reply-headers 'ERROR_NAME))
             (body (d-bus-message-body reply)))
        ;; Validate the reply matches the message.
        (when error-name
          (error 'dbus "method failed with error" error-name body))
        ;; Some replies do not include a serial header, such as the for the
        ;; org.freedesktop.DBus NameAcquired one.
        (if (and reply-serial (= serial reply-serial))
            (match body
              ((x x* ..1)               ;contains 2 ore more elements
               body)
              ((x)
               x)                       ;single element; return it directly
              (#f #f))
            (retry))))))

(define (argument->signature-type argument)
  "Infer the D-Bus signature type from ARGUMENT."
  ;; XXX: avoid ..1 when using vectors due to a bug (?) in (ice-9 match).
  (match argument
    ((? boolean?) "b")
    ((? string?) "s")
    (#((? string?) (? string?) ...) "as")
    (#(((? string?) . (? string?))
       ((? string?) . (? string?)) ...) "a{ss}")
    (_ (error 'dbus "no rule to infer type from argument" argument))))

(define* (call-dbus-method method
                           #:key
                           (path "/org/freedesktop/DBus")
                           (destination "org.freedesktop.DBus")
                           (interface "org.freedesktop.DBus")
                           (connection (%current-dbus-connection))
                           arguments
                           timeout)
  "Call the D-Bus method specified by METHOD, PATH, DESTINATION and INTERFACE.
The currently active D-Bus CONNECTION is used unless explicitly provided.
Method arguments may be provided via ARGUMENTS sent as the message body.
TIMEOUT limit the maximum time to allow for the reply.  Return the body of the
reply."
  (let ((message (make-d-bus-message
                  MESSAGE_TYPE_METHOD_CALL 0 #f '()
                  `#(,(header-PATH        path)
                     ,(header-DESTINATION destination)
                     ,(header-INTERFACE   interface)
                     ,(header-MEMBER      method)
                     ,@(if arguments
                           (list (header-SIGNATURE
                                  (string-join
                                   (map argument->signature-type arguments)
                                   "")))
                           '()))
                  arguments)))
    (send-dbus message #:connection connection #:timeout timeout)))


;;;
;;; Higher-level, D-Bus procedures.
;;;

(define (dbus-available-services)
  "Return the list of available (acquired) D-Bus services."
  (let ((names (vector->list (call-dbus-method "ListNames"))))
    ;; Remove entries such as ":1.7".
    (remove (cut string-prefix? ":" <>) names)))

(define (dbus-service-available? service)
  "Predicate to check for the D-Bus SERVICE availability."
  (member service (dbus-available-services)))

;; Local Variables:
;; eval: (put 'with-retries 'scheme-indent-function 2)
;; End: