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 (context 'DbusInterface)
 164 (FOOP name members)
 165
 166 ;; FOOP constructor; remember the interface name
 167 (define (DbusInterface:DbusInterface NAME (MEMBERS '()))
 168   (list (context) NAME MEMBERS))
 169
 170 ;; Utility method to expand a member with interface prefix
 171 (define (m MEMBER)
 172   (string (%name) "." MEMBER))
 173
 174 ;; Install this interface into the context of the caller
 175 (define (use)
 176   (let ((IF (when (regex "([^.]+)$" (%name) 0) $1))
 177         (CC (prefix (first (or (1 (history)) '(MAIN))))))
 178     (letex ((S (sym $1 CC)) (V (self)))
 179       (begin (context CC) (constant 'S 'V)))))
 180
 181 ;; Declare additional members for this interface
 182 (define (has)
 183   (dolist (MEMBER (args))
 184     (unless (member MEMBER (%members))
 185       (!members (push MEMBER (%members) -1)))))
 186
 187 ;;######################################################################
 188 ;;
 189 ;; Standard interfaces
 190
 191 (context MAIN)
 192
 193 (:use (DbusInterface "org.freedesktop.DBus.Peer"
 194                      '( "Ping()"
 195                         "GetMachineId()" ; s
 196                         )))
 197
 198 (:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
 199                      '( "GetManagedObjects()" ; a(oa(sa(sv)))
 200                         )))
 201
 202 (:use (DbusInterface "org.freedesktop.DBus.Introspectable"
 203                      ' Introspectable "Introspect()" ; s (xml data)
 204                        ))
 205 ; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format
 206
 207 (:use (DbusInterface "org.freedesktop.DBus.Properties"
 208                      '( "Get(ss)" ; v
 209                         "Set(ssv)" ; --
 210                         "GetAll(s)" ; a(sv)
 211                         "PropertiesChanged(sa(sv)as)" ; signal ?
 212                         )))
 213
 214 (:use (DbusInterface "org.freedesktop.DBus"
 215                      '( "Hello()" ; s
 216                         "RequestName(su)" ; u
 217                         "ReleaseName(s)" ; u
 218                         "ListQueuedOwners (s)" ; as
 219                         "ListNames()" ; as
 220                         "ListActivatableNames()" ; as
 221                         "NameHasOwner(s)" ; b
 222                         "NameOwnerChanged(sss)" ;   -- signal
 223                         "NameLost(s)" ;  -- signal
 224                         "NameAcquired(s)" ;  -- signal
 225                         "ActivatableServicesChanged()" ;  -- signal
 226                         "StartServiceByName(s,u)" ; u
 227                         "UpdateActivationEnvironment(a(ss))" ; ?
 228                         "GetNameOwner(s)" ; s
 229                         "GetConnectionUnixUser(s)" ; u
 230                         "GetConnectionUnixProcessID(s)" ; u
 231                         "GetConnectionCredentials(s)" ; a(sv)
 232                         "GetAdtAuditSessionData(s)" ; ay
 233                         "GetConnectionSELinuxSecurityContext(s)" ; ay
 234                         "AddMatch(s)" ;
 235                         "RemoveMatch(s)" ; ?
 236                         "GetId()" ; s
 237                         "Monitoring.BecomeMonitor(asu)" ; ?
 238                         )))
 239
 240 ;eg AddMatch argument:
 241 ;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"
 242
 243 "lsp-dbus.lsp"