;; 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:prog1) (load "misc.lsp"))
(unless (context? MAIN:DbusConnection) (load "lsp-dbus-connection.lsp"))

#################################################################
;; The DbusInterface context is used for modelling DBus interfaces.
;;
;; It includes in particular the :use method for installing a
;; DbusInterface FOOP object as a constant named by the interface.
;; E.g. (:use (DbusInterface "org.freedesktop.DBus.ObjectManager")
;; installes the constant ObjectManager with a DbusInterface FOOP
;; object modelling that interface.
;;
;; The :m method is used to construct a fullly qualified method name.
;; E.g. (:m ObjectManager "GetManagedObjects()") assuming the prior
;; :use installation of ObjectManager results in the fully qualified
;; name string
;;     "org.freedesktop.DBus.ObjectManager.GetManagedObjects()"
;; 
(context 'DbusInterface)
(FOOP name members)

;; FOOP constructor; remember the interface name
(define (DbusInterface:DbusInterface NAME (MEMBERS '()))
  (list (context) NAME MEMBERS))

;; Utility method to expand a member with the interface prefix. When
;; the MEMBER is given without "(", then it is duly looked up in the
;; MEMBERS list of the DbusInterface, and it thus gets expanded with
;; parameter signature.
(define (m MEMBER)
  (unless (find "(" MEMBER)
    (if (ref (string MEMBER "(") (%members) (fn (x y) (starts-with y x)) true)
        (setf MEMBER ((parse $it ":") 0))))
  (string (%name) "." MEMBER))

;; Install this interface into the context of the caller
(define (use)
  (let ((IF (when (regex "([^.]+)$" (%name) 0) $1))
        (CC (prefix (first (or (1 (history)) '(MAIN))))))
    (letex ((S (sym $1 CC)) (V (self)))
      (begin (context CC) (constant 'S 'V)))))

;; Declare additional members for this interface
(define (has)
  (dolist (MEMBER (args))
    (unless (member MEMBER (%members))
      (!members (push MEMBER (%members) -1)))))

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

;; Declaring the FOOP object
(FOOP path name bus)

;; "The FOOP Constructor". Creates an object for a given path.
(define (Dbus:Dbus PATH (NAME (replace "/" (1 PATH) ".")) (BUS 'SYSTEM-BUS))
  (list (context) PATH NAME BUS))

;; Method to clone a proxy for a given path/object.
(define (new-path PATH)
  (list (context) PATH (%name) (%bus)))

;; Update the connection serial and return it
(define (connection++)
  (case (%bus)
    (SYSTEM-BUS (:serial++ SYSTEM-BUS))
    (true 0)))

; Include marshalling functions and signal handling framework
(load "lsp-dbus-marshal.lsp" (context))
(load "lsp-dbus-events.lsp" (context))

;; ====================
;; Dbus symbols

(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")
                    )
 )

;; Map message type symbol to dbus type code (i.e. the list index)
(define (message-type-code TYPE)
  (or (find TYPE MESSAGE-TYPES =) 0))

;; Map flag symbol F to its dbus "bit code"
(define (flag F)
  (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))

;; Return the dbus flags code from FLAGS; if it is a number thent tha
;; is returned as is; if FLAGS is a list of message flag symbols then
;; combine their codes by bit-OR. Anything else yields 0.
(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)
  (when (list? HDR)
    (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
        (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))

;; Join the excess string arguments N-byte alignment successively
(define (pad-join N)
  (let ((OUT ""))
    (dolist (S (args))
      (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
        (extend OUT PAD S)))
    OUT))

;; Return a marshalled message string appended by the marshalled body
(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)
                             (connection++)
                             (clean null? (map message-header HDRS))))
            BODY ))

;; (:invoke OBJ METHOD ARGS FLAGS)
; Perform a METHOD_CALL on the (self) object
;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
;; "INTERFACE." bit optional. The function returns the list of headers
;; of the reply message extended with reply value as a faked header
;; named "".
;;
;; This function calls send-recv-message which also polls for signals
;; until a reply is given, but any such signals are stocked up as
;; pending for later processing on demand.
(define (invoke METHOD ARGS (FLAGS 0))
  (when (regex "((.+):)?((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
    (let ((PATH $2) (INTERFACE $4) (MEMBER $5) (SIGNATURE $6))
      ;;(println (list 'invoke (%name) INTERFACE MEMBER SIGNATURE))
      (if (message 'METHOD_CALL FLAGS
                   (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
                         (list 'DESTINATION (%name))
                         (list 'PATH (if (empty? PATH) (%path) PATH))
                         (if (empty? INTERFACE) nil
                           (list 'INTERFACE INTERFACE))
                         (list 'MEMBER MEMBER)
                         (if (empty? SIGNATURE) nil
                           (list 'SIGNATURE SIGNATURE))
                         )
                   (if (empty? SIGNATURE) ""
                     (pack-data SIGNATURE ARGS)))
          (send-recv-message $it)
        nil
        ))))

;; Context variables and framework registration
(setf
 SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
 APPID (:initialize SYSTEM-BUS)
 ROOT (Dbus "/org/freedesktop/DBus")
 DBus (DbusInterface "org.freedesktop.DBus")
 APPNAME (if (:invoke ROOT (:m DBus "Hello()"))
             ($it -1 -1 -1))
 )

;; Installation of some framework notification handlers

;; Helper method to notify
(define (signal-trace ARGS)
  (die nil "** Got:" KEY ARGS ))

(:handler ROOT (:m DBus "NameAcquired(s)") signal-trace)
(:handler ROOT (:m DBus "NameLost(s)") signal-trace)
(:handler ROOT (:m DBus "NameOwnerChanged(sss)") signal-trace)

 ; Process notifications that came with the registration handshake
(process-all-pending)

;; Set up the Dbus event loop as prompt-event handler
(prompt-event Dbus:main-loop)

;;######################################################################
;;
;; Standard interfaces

(context MAIN)

(:use (DbusInterface "org.freedesktop.DBus.Peer"
                     '( "Ping():"
                        "GetMachineId():s"
                        )))

(:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
                     '( "GetManagedObjects():a(oa(sa(sv)))"
                        )))

(:use (DbusInterface "org.freedesktop.DBus.Introspectable"
                     ' Introspectable "Introspect():s" ; (xml data)
                       ))
; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format

(:use (DbusInterface "org.freedesktop.DBus.Properties"
                     '( "Get(ss):v"
                        "Set(ssv):"
                        "GetAll(s):a(sv)"
                        "PropertiesChanged(sa(sv)as):" ; signal ?
                        )))

(:use (DbusInterface "org.freedesktop.DBus"
                     '( "Hello():s"
                        "RequestName(su):u"
                        "ReleaseName(s):u"
                        "ListQueuedOwners (s):as"
                        "ListNames():as"
                        "ListActivatableNames():as"
                        "NameHasOwner(s):b"
                        "NameOwnerChanged(sss):" ;  -- signal
                        "NameLost(s):" ; -- signal
                        "NameAcquired(s):" ; -- signal
                        "ActivatableServicesChanged():" ; -- signal
                        "StartServiceByName(s,u):u"
                        "UpdateActivationEnvironment(a(ss)):"
                        "GetNameOwner(s):s"
                        "GetConnectionUnixUser(s):u"
                        "GetConnectionUnixProcessID(s):u"
                        "GetConnectionCredentials(s):a(sv)"
                        "GetAdtAuditSessionData(s):ay"
                        "GetConnectionSELinuxSecurityContext(s):ay"
                        "AddMatch(s):"
                        "RemoveMatch(s):"
                        "GetId():s"
                        "Monitoring.BecomeMonitor(asu):"  
                        )))

;eg AddMatch argument:
;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"

"lsp-dbus.lsp"