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