;; This newlisp "module" sets up a dbus API adapter
;;
;; dbus is an object oriented interprocess commmunications framework
;; based on utual object proxying. This end holds some objects that
;; remote ends can access and invoke methods on, and remote ends hold
;; objects that this pocess can access and invoke methods on.
;;
;; https://dbus.freedesktop.org/doc/dbus-specification.html
;; https://dbus.freedesktop.org/doc/dbus-api-design.html
;; [C API] https://dbus.freedesktop.org/doc/api/html/
;;

(unless (context? MAIN:FOOP) (load "foop.lsp"))
(unless (context? MAIN:DbusConnection) (load "lsp-dbus-connection.lsp"))

#################################################################
(context 'MAIN:Dbus)

; Include marshalling functions
(load "lsp-dbus-marshal.lsp" MAIN:Dbus)

;; Declaring the FOOP object
(FOOP path bus)


(setf SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket"))
(:initialize SYSTEM-BUS)

;; "Constructor". Creates an adapter object for a given base path.
(define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS))
  (list (context) PATH BUS))

;; Return the bus name
(define (bus-name)
  (join (find-all "([^/]+)" (%path) $1 0) "."))

;; Return the DbusConnection connection adapter 
(define (connection)
  (eval (%bus)))

;; ====================
;; Dbus messages

(constant
 'PROTOCOL-VERSION '(1 1)
 'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
 'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
                  NO_AUTO_START
                  ALLOW_INTERACTIVE_AUTHORIZATION)
 ;; Message headers: [code] (name type)
 'MESSAGE-HEADERS '((INVALID )
                    (PATH "o")
                    (INTERFACE "s")
                    (MEMBER "s")
                    (ERROR_NAME "s")
                    (REPLY_SERIAL "i")
                    (DESTINATION "s")
                    (SENDER "s")
                    (SIGNATURE "g")
                    (UNIX_FDS "i")
                    )
 )

;; Determine the type code = index of teh type symbol in the
;; MESSAGE-TYPES list.
(define (message-type-code TYPE)
  (or (find TYPE MESSAGE-TYPES =) 0))

(define (flag F)
  (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))

;; Combining header flag symbols into the flags code = bit-or of the
;; 2^x values where x is the index for the flag symbol in the
;; MESSAGE-FLAGS list.
(define (message-flags FLAGS)
  (if (number? FLAGS) FLAGS
    (list? FLAGS) (apply | (map flag FLAGS))
    0))

;; (message-header (NAME VALUE))
; Translate header into its marshalling data. The name is mapped to
; its header code and associated value type. This gets translated into
; the marshalling data form of (code (type value))
(define (message-header HDR)
  (let ((CODE (find (list (HDR 0) '*) MESSAGE-HEADERS match) 0))
    (list CODE (list (MESSAGE-HEADERS CODE 1) (HDR 1)))))

;; Return a marshalled message
(define (message TYPE FLAGS HDRS BODY)
  (pad-join 8
            (pack-data "yyyyuua(yv)"
                       (list (char "l")
                             (message-type-code TYPE)
                             (message-flags FLAGS)
                             (PROTOCOL-VERSION 0) ; Major version code
                             (length BODY)
                             (:serial++ (connection))
                             (map message-header HDRS)))
            BODY))

(define (method-body ARGS)
  "")

;; Invoke a method on an object via dbus
; (:invoke OBJ MEMBER INTERFACE FLAGS)
(define (invoke MEMBER INTERFACE (FLAGS 0))
  (or INTERFACE (setf INTERFACE (bus-name)))
  (if (message 'METHOD_CALL FLAGS
               (list (list 'PATH (%path))
                     (list 'DESTINATION (bus-name))
                     (list 'INTERFACE INTERFACE)
                     (list 'MEMBER MEMBER))
               (method-body (args)))
      (begin
        (let ((MSG $it) (BUFFER "") (RESULT "") (S (:%socket (connection))))
          (net-send S MSG)
          (while (net-select S "r" 1000)
            (net-receive S BUFFER 8192)
            (extend RESULT BUFFER))
          BUFFER))
    nil
    ))

"lsp-dbus.lsp"