;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 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.
;;;
;;; 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))))))

\f
;;;
;;; 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))))

\f
;;;
;;; 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))))))

\f
;;;
;;; 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)))