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