;; This newlisp module implements dbus socket send-receive together
;; with signal receive. (This file should be loaded into the Dbus
;; context)
;;
;; The REPL loop is re-mastered by means of a prompt-event function
;; that firstly handles any pending dbus messages, and secondly
;; net-select on both the dbus socket and stdin.
;;
;; Stdin is handled with priority.
;;
;; Dbus messages are read and added to the pending list.
;;
;; Handlers are set up as functions (fn (data msg) ..) identified by
;; "dbus callback key" consisting of path, interface, method and
;; signature separated by ":". For example:
;;
;;    "/org/freedesktop/DBus:org.freedesktop.DBus.NameAcquired(s)"
;;
;; would identify the handler for the NameAcquired(string) method of
;; the interface "org.freedesktop.DBus" of the path
;; "/org/freedesktop/DBus" of the client. That particular callback is
;; a s.c. signal sent by the dbus framework implementation in reaction
;; to the initial Hello call, i.e. the s.c. invocation of
;;
;;    "/org/freedesktop/DBus:org.freedesktop.DBus.Hello()"
;;

;; Return the callback key for a message MSG
(define (message-key MSG)
  (string (lookup 'PATH MSG) ":" (lookup 'INTERFACE MSG) "."
          (lookup 'MEMBER MSG) "(" (lookup 'SIGNATURE MSG) ")" ))

;; This is the table of handlers, keyed by path:interface:method:signature
(define RECV:RECV nil)

;; Utility function to install a handler for a given key,
(define (handler KEY HANDLER)
  (RECV (string (%path) ":" KEY) HANDLER))

;; This is the list of Dbus messages still to handle.
(setf pending '())

(define (no-handler KEY MSG)
  (write-line 2 (format "** No handler %s for:\n%s" KEY (string MSG))))

(define (process-message MSG)
  (let ((KEY (message-key MSG)))
    (if (RECV KEY) ($it (lookup "" MSG))
      (no-handler KEY MSG))))

;; Process all messages currently pending
(define (process-all-pending)
  (while (if (pop pending) (process-message $it))))

;; The main-loop is intended as a prompt-handler so as to deal with
;; asyncronous events
(define (main-loop S)
  (let ((FDS (list 0 (:%socket SYSTEM-BUS))) (FD nil))
    (write 2 (string "> "))
    (while (or pending (not (member 0 (net-select FDS "r" -1))))
      (if (pop pending) (process-message $it)
        (if (unpack-messages (or (:read-message SYSTEM-BUS) ""))
            (extend pending $it))
        ))
    "main-loop: "))

(define (human-msg MSG)
  (human-bytes (unpack (dup "b" (length MSG)) MSG)))

;; Send message, then keep reading messages until there is a reply
(define (send-recv-message MSG)
  ;;(die nil (list 'send-recv-message (human-msg MSG)))
  (net-send (:%socket SYSTEM-BUS) MSG)
  (let ((REPLY nil))
    (while (nil? REPLY)
      (dolist (M (unpack-messages (:read-message SYSTEM-BUS)))
        (if (lookup 'REPLY_SERIAL M) (setf REPLY M)
          (push M pending -1))))
    REPLY))

"lsp-dbus-events.lsp"