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