lsp-dbus/lsp-dbus.lsp

   1 ;; This newlisp "module" sets up a dbus API adapter
   2 ;;
   3 ;; dbus is an object oriented interprocess commmunications framework
   4 ;; based on utual object proxying. This end holds some objects that
   5 ;; remote ends can access and invoke methods on, and remote ends hold
   6 ;; objects that this pocess can access and invoke methods on.
   7 ;;
   8 ;; https://dbus.freedesktop.org/doc/dbus-specification.html
   9 ;; https://dbus.freedesktop.org/doc/dbus-api-design.html
  10 ;; [C API] https://dbus.freedesktop.org/doc/api/html/
  11 ;;
  12
  13 (unless (context? MAIN:FOOP) (load "foop.lsp"))
  14 (unless (context? MAIN:prog1) (load "misc.lsp"))
  15 (unless (context? MAIN:DbusConnection) (load "lsp-dbus-connection.lsp"))
  16
  17 #################################################################
  18 (context 'MAIN:Dbus)
  19
  20 ;; Declaring the FOOP object
  21 (FOOP path bus)
  22
  23 ;; "The FOOP Constructor". Creates an object for a given path.
  24 (define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS))
  25   (list (context) PATH BUS))
  26
  27 ;; Return the bus name
  28 (define (bus-name)
  29   (join (find-all "([^/]+)" (%path) $1 0) "."))
  30
  31 ;; Update the connection serial and return it
  32 (define (connection++)
  33   (case (%bus)
  34     (SYSTEM-BUS (:serial++ SYSTEM-BUS))
  35     (true 0)))
  36
  37 ; Include marshalling functions and signal handling framework
  38 (load "lsp-dbus-marshal.lsp" (context))
  39 (load "lsp-dbus-events.lsp" (context))
  40
  41 ;; ====================
  42 ;; Dbus symbols
  43
  44 (constant
  45  'PROTOCOL-VERSION '(1 1)
  46  'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
  47  'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
  48                   NO_AUTO_START
  49                   ALLOW_INTERACTIVE_AUTHORIZATION)
  50  ;; Message headers: [code] => (name type)
  51  'MESSAGE-HEADERS '((INVALID )
  52                     (PATH "o")
  53                     (INTERFACE "s")
  54                     (MEMBER "s")
  55                     (ERROR_NAME "s")
  56                     (REPLY_SERIAL "i")
  57                     (DESTINATION "s")
  58                     (SENDER "s")
  59                     (SIGNATURE "g")
  60                     (UNIX_FDS "i")
  61                     )
  62  )
  63
  64 ;; Map message type symbol to dbus type code (i.e. the list index)
  65 (define (message-type-code TYPE)
  66   (or (find TYPE MESSAGE-TYPES =) 0))
  67
  68 ;; Map flag symbol F to its dbus "bit code"
  69 (define (flag F)
  70   (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
  71
  72 ;; Return the dbus flags code from FLAGS; if it is a number thent tha
  73 ;; is returned as is; if FLAGS is a list of message flag symbols then
  74 ;; combine their codes by bit-OR. Anything else yields 0.
  75 (define (message-flags FLAGS)
  76   (if (number? FLAGS) FLAGS
  77     (list? FLAGS)
  78     (apply | (map flag FLAGS))
  79     0))
  80
  81 ;; (message-header (NAME VALUE))
  82 ; Translate header into its marshalling data. The name is mapped to
  83 ; its header code and associated value type. This gets translated into
  84 ; the marshalling data form of (code (type value))
  85 (define (message-header HDR)
  86   (when (list? HDR)
  87     (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
  88         (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))
  89
  90 ;; Join the excess string arguments N-byte alignment successively
  91 (define (pad-join N)
  92   (let ((OUT ""))
  93     (dolist (S (args))
  94       (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
  95         (extend OUT PAD S)))
  96     OUT))
  97
  98 ;; Return a marshalled message string appended by the marshalled body
  99 (define (message TYPE FLAGS HDRS BODY)
 100   (pad-join 8
 101             (pack-data "yyyyuua(yv)"
 102                        (list (char "l")
 103                              (message-type-code TYPE)
 104                              (message-flags FLAGS)
 105                              (PROTOCOL-VERSION 0) ; Major version code
 106                              (length BODY)
 107                              (connection++)
 108                              (clean null? (map message-header HDRS))))
 109             BODY ))
 110
 111 ;; (:invoke OBJ METHOD ARGS FLAGS)
 112 ; Perform a METHOD_CALL on the (self) object
 113 ;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
 114 ;; "INTERFACE." bit optional. The function returns the list of headers
 115 ;; of the reply message extended with reply value as a faked header
 116 ;; named "".
 117 ;;
 118 ;; This function calls send-recv-message which also polls for signals
 119 ;; until a reply is given, but any such signals are stocked up as
 120 ;; pending for later processing on demand.
 121 (define (invoke METHOD ARGS (FLAGS 0))
 122   (when (regex "((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
 123     (let ((INTERFACE $2) (MEMBER $3) (SIGNATURE $4))
 124       ;;(println (list 'invoke (bus-name) INTERFACE MEMBER SIGNATURE))
 125       (if (message 'METHOD_CALL FLAGS
 126                    (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
 127                          (list 'DESTINATION (bus-name))
 128                          (list 'PATH (%path))
 129                          (if (empty? INTERFACE) nil
 130                            (list 'INTERFACE INTERFACE))
 131                          (list 'MEMBER MEMBER)
 132                          (if (empty? SIGNATURE) nil
 133                            (list 'SIGNATURE SIGNATURE))
 134                          )
 135                    (if (empty? SIGNATURE) ""
 136                      (pack-data SIGNATURE ARGS)))
 137           (send-recv-message $it)
 138         nil
 139         ))))
 140
 141 ;; Context variables and framework registration
 142
 143 (setf
 144  SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
 145  APPID (:initialize SYSTEM-BUS)
 146  ROOT (Dbus "/org/freedesktop/DBus")
 147  APPNAME (if (lookup "" (:invoke ROOT "org.freedesktop.DBus.Hello()"))
 148                ($it 0))
 149  )
 150
 151 ;; Installation of some framework notification handlers
 152
 153 ;; Helper method to notify
 154 (define (signal-trace ARGS)
 155   (die nil "** Got:" KEY ARGS ))
 156
 157 (:handler ROOT "org.freedesktop.DBus.NameAcquired(s)" signal-trace)
 158 (:handler ROOT "org.freedesktop.DBus.NameLost(s)" signal-trace)
 159 (:handler ROOT "org.freedesktop.DBus.NameOwnerChanged(sss)" signal-trace)
 160
 161  ; Process notifications that came with the registration handshake
 162 (process-all-pending)
 163
 164 ;; Set up the Dbus event loop as prompt-event handler
 165 (prompt-event Dbus:main-loop)
 166
 167 ;;######################################################################
 168 ;;
 169 ;; Some tidbits
 170
 171 ;;org.freedesktop.DBus.Peer.Ping ()
 172 ;;org.freedesktop.DBus.Peer.GetMachineId (out STRING machine_uuid)
 173 ;;org.freedesktop.DBus.Introspectable.Introspect (out STRING xml_data)
 174 ;;org.freedesktop.DBus.Properties.Get (
 175 ;;            in STRING interface_name,
 176 ;;            in STRING property_name,
 177 ;;            out VARIANT value);
 178 ;;org.freedesktop.DBus.Properties.Set (
 179 ;;            in STRING interface_name,
 180 ;;            in STRING property_name,
 181 ;;            in VARIANT value);
 182 ;;org.freedesktop.DBus.Properties.GetAll (
 183 ;;            in STRING interface_name,
 184 ;;            out ARRAY of DICT_ENTRY<STRING,VARIANT> props);
 185 ;;org.freedesktop.DBus.Properties.PropertiesChanged (
 186 ;;            STRING interface_name,
 187 ;;            ARRAY of DICT_ENTRY<STRING,VARIANT> changed_properties,
 188 ;;            ARRAY<STRING> invalidated_properties);
 189 ;;org.freedesktop.DBus.ObjectManager.GetManagedObjects (
 190 ;;            out ARRAY of
 191 ;;               DICT_ENTRY<OBJPATH,ARRAY of
 192 ;;                  DICT_ENTRY<STRING,ARRAY of
 193 ;;                     DICT_ENTRY<STRING,VARIANT>>>
 194 ;;            objpath_interfaces_and_properties);
 195 ;;;;
 196 ;;org.freedesktop.DBus.Hello():s
 197 ;;org.freedesktop.DBus.RequestName(su):u
 198 ;;org.freedesktop.DBus.ReleaseName(s):u
 199 ;;org.freedesktop.DBus.ListQueuedOwners (s):as
 200 ;;org.freedesktop.DBus.ListNames():as
 201 ;;org.freedesktop.DBus.ListActivatableNames():as
 202 ;;org.freedesktop.DBus.NameHasOwner(s):b
 203 ;;org.freedesktop.DBus.NameOwnerChanged(sss) -- signal
 204 ;;org.freedesktop.DBus.NameLost(s) -- signal
 205 ;;org.freedesktop.DBus.NameAcquired(s) -- signal
 206 ;;org.freedesktop.DBus.ActivatableServicesChanged() -- signal
 207 ;;org.freedesktop.DBus.StartServiceByName(s,u):u
 208 ;;org.freedesktop.DBus.UpdateActivationEnvironment(a(ss)):?
 209 ;;org.freedesktop.DBus.GetNameOwner(s):s
 210 ;;org.freedesktop.DBus.GetConnectionUnixUser(s):u
 211 ;;org.freedesktop.DBus.GetConnectionUnixProcessID(s):u
 212 ;;org.freedesktop.DBus.GetConnectionCredentials(s):a(sv)
 213 ;;org.freedesktop.DBus.GetAdtAuditSessionData(s):ay
 214 ;;org.freedesktop.DBus.GetConnectionSELinuxSecurityContext(s):ay
 215 ;;org.freedesktop.DBus.AddMatch(s):? (org.freedesktop.DBus.Error.OOM)
 216 ;;org.freedesktop.DBus.RemoveMatch(s):?
 217 ;;org.freedesktop.DBus.GetId():s
 218 ;;org.freedesktop.DBus.Monitoring.BecomeMonitor(asu):?
 219
 220 ;;org.freedesktop.DBus.AddMatch(s)
 221 ;eg
 222 ;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"
 223
 224 ;;org.freedesktop.DBus.StartServiceByName(?)
 225 ;;org.freedesktop.DBus.NameOwnerChanged(?)
 226
 227 "lsp-dbus.lsp"