dbus-api.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 ; Require the FOOP context
  14 (unless (context? MAIN:FOOP) (load "foop.lsp"))
  15
  16 #################################################################
  17 ;; This newlisp module implements dbus socket connection
  18 ;; originally lsp-dbus-connection.lsp
  19
  20 (context 'MAIN:DbusConnection)
  21 (FOOP path socket name serial)
  22
  23 (define (DbusConnection:DbusConnection PATH)
  24   (list (context) PATH -1 nil 0))
  25
  26 ;; Increment the serial and return it.
  27 (define (serial++)
  28   (!serial (+ 1 (%serial))))
  29
  30 ;; (open-socket)
  31 ; Internal utility method to re-open the %path socket and set the
  32 ; %socket field.
  33 (define (open-socket)
  34   (when (>= (%socket))
  35     (close (%socket))
  36     (!socket -1))
  37   (!socket (net-connect (%path))))
  38
  39 ;** Commands from client to server
  40 ; AUTH [mechanism] [initial-response]
  41 ; CANCEL
  42 ; BEGIN
  43 ; DATA <data in hex encoding>
  44 ; ERROR [human-readable error explanation]
  45 ; NEGOTIATE_UNIX_FD
  46
  47 ;** Commands from server to client
  48 ; REJECTED <space-separated list of mechanism names>
  49 ; OK <GUID in hex>
  50 ; DATA <data in hex encoding>
  51 ; ERROR [human-readable error explanation]
  52 ; AGREE_UNIX_FD
  53
  54 (define (read-message)
  55   (let ((BUFFER "") (RESULT ""))
  56     (while (and RESULT (net-select (%socket) "r" 1000))
  57       (if (net-receive (%socket) BUFFER 8192)
  58           (extend RESULT BUFFER)
  59         (begin
  60           (setf RESULT nil)
  61           (die 1 "dbus socket closed"))
  62         ))
  63     RESULT))
  64
  65 ;; (handshake MSG PAT)
  66 ; Perform a socket handshake sending MSG and return the result, or if
  67 ; PAT not nil, then return (regex PAT RESULT 0),
  68 (define (handshake MSG PAT)
  69   (let ((RESULT ""))
  70     (net-send (%socket) MSG)
  71     (setf RESULT (read-message))
  72     (if PAT (regex PAT RESULT 0) RESULT)))
  73
  74 (constant
  75  'AUTHFMT "AUTH EXTERNAL %s\r\n"
  76  'AUTHACK "OK (\\S+)\r\n"
  77  'KEEPFMT "NEGOTIATE_UNIX_FD\r\n"
  78  'KEEPACK "AGREE_UNIX_FD\r\n"
  79  )
  80
  81 ;; (initialize USER)
  82 ; Perform socket initialization sequence and return the name, or nil.
  83 (define (initialize (USER (env "USER")))
  84   (when (and (>= (open-socket))
  85              (net-send (%socket) (char 0))
  86              (handshake (format AUTHFMT (char2hex USER)) AUTHACK)
  87              (!name $1)
  88              (handshake KEEPFMT KEEPACK))
  89     (handshake "BEGIN\r\n")
  90     (%name)))
  91
  92 (define (cancel)
  93   (handshake "CANCEL\r\n" "(.*)"))
  94
  95 #################################################################
  96 ;; The DbusInterface context is used for modelling DBus interfaces.
  97 ;;
  98 ;; It includes in particular the :use method for installing a
  99 ;; DbusInterface FOOP object as a constant named by the interface.
 100 ;; E.g. (:use (DbusInterface "org.freedesktop.DBus.ObjectManager")
 101 ;; installes the constant ObjectManager with a DbusInterface FOOP
 102 ;; object modelling that interface.
 103 ;;
 104 ;; The :m method is used to construct a fullly qualified method name.
 105 ;; E.g. (:m ObjectManager "GetManagedObjects()") assuming the prior
 106 ;; :use installation of ObjectManager results in the fully qualified
 107 ;; name string
 108 ;;     "org.freedesktop.DBus.ObjectManager.GetManagedObjects()"
 109 ;;
 110 (context 'MAIN:DbusInterface)
 111 (FOOP name members)
 112
 113 ;; FOOP constructor; remember the interface name
 114 (define (DbusInterface:DbusInterface NAME (MEMBERS '()))
 115   (list (context) NAME MEMBERS))
 116
 117 ;; Utility method to expand a member with the interface prefix. When
 118 ;; the MEMBER is given without "(", then it is duly looked up in the
 119 ;; MEMBERS list of the DbusInterface, and it thus gets expanded with
 120 ;; parameter signature.
 121 (define (m MEMBER)
 122   (unless (find "(" MEMBER)
 123     (if (ref (string MEMBER "(") (%members) (fn (x y) (starts-with y x)) true)
 124         (setf MEMBER ((parse $it ":") 0))))
 125   (string (%name) "." MEMBER))
 126
 127 ;; Install this interface into the context of the caller
 128 (define (use)
 129   (let ((IF (when (regex "([^.]+)$" (%name) 0) $1))
 130         (CC (prefix (first (or (1 (history)) '(MAIN))))))
 131     (letex ((S (sym $1 CC)) (V (self)))
 132       (begin (context CC) (constant 'S 'V)))))
 133
 134 ;; Declare additional members for this interface
 135 (define (has)
 136   (dolist (MEMBER (args))
 137     (unless (member MEMBER (%members))
 138       (!members (push MEMBER (%members) -1)))))
 139
 140 #################################################################
 141 (context 'MAIN:Dbus)
 142
 143 ;; Declaring the FOOP object
 144 (FOOP path name bus)
 145
 146 ;; "The FOOP Constructor". Creates an object for a given path.
 147 (define (Dbus:Dbus PATH (NAME (replace "/" (1 PATH) ".")) (BUS 'SYSTEM-BUS))
 148   (list (context) PATH NAME BUS))
 149
 150 ;; Method to clone a proxy for a given path/object.
 151 (define (new-path PATH)
 152   (list (context) PATH (%name) (%bus)))
 153
 154 ;; Update the connection serial and return it
 155 (define (connection++)
 156   (case (%bus)
 157     (SYSTEM-BUS (:serial++ SYSTEM-BUS))
 158     (true 0)))
 159
 160 ;; marshalling functions and signal handling framework
 161 ;; originallt lsp-dbus-marshal.lsp
 162 ;
 163 ; The newlisp representation is a simplified form using lists for
 164 ; structs and arrays.
 165
 166 ;; (expand-signature S)
 167 ; Expland a signature string into a nested list to correspond to the
 168 ; newlisp list representation.
 169 ;; Basic dbus types are basic newlisp types, including strings. Arrays
 170 ;; and structs are sublists; the expanded signature marks array
 171 ;; sublists with an initial "a", otherwise it's a struct sublist.
 172 ;
 173 ; Ex: "yi" = ("y" "i")
 174 ; Ex: "y(ai)" = ("y" (("a" "i")))
 175 ; Ex: "a(yi)" = (("a" ("y" "i")))
 176 ; Ex: "yyyyuua(yv)" = ("y" "y" "y" "y" "u" "u" ("a" ("y" "v")))
 177 (define (expand-signature S)
 178   (setf S (replace "{" (replace "}" (copy S) ")") "("))
 179   (let ((STACK '()) (CUR '()) (A 0))
 180     (dolist (X (explode S))
 181       (case X
 182         (")" (setf X CUR) (setf CUR (pop STACK)))
 183         ("(" (push CUR STACK) (setf CUR '()))
 184         (true true))
 185       (when (and (!= X "a") (!= X "("))
 186         (while (and CUR (= "a" (last CUR)))
 187           (setf X (list (last CUR) X))
 188           (setf CUR (chop CUR))))
 189       (when (!= "(" X)
 190         (push X CUR -1)))
 191     (if (null? CUR) '() CUR)))
 192
 193 ;; Align AT to an I multiple and pad DATA with as many NUL bytes at
 194 ;; front, then increment AT past it all.
 195 (define (pack-align DATA (I (length DATA)))
 196   (let ((PAD (dup "\000" (% (- I (% AT I)) I))))
 197     (setf DATA (extend PAD DATA))
 198     (inc AT (length DATA))
 199     DATA))
 200
 201 ;; Pack data from DATA according to signature. The DATA is a nested
 202 ;; list where container types are sub lists. Variant types also appear
 203 ;; as pairs of signature and value.
 204 (define (pack-data SIGN DATA)
 205   (let ((AT 0)) (pack-data-struct (expand-signature SIGN) DATA)))
 206
 207 ;; Pack a newlisp data element according to marshalling type The
 208 ;; newlisp data is integer, double, string or list (for container and
 209 ;; variant elements).
 210 (constant
 211  'FMTMAP ; mapping dbus type code to byte size and newlisp code
 212  '( ("y" 1 "b")  ; BYTE (unsigned 8-bit integer)
 213     ("b" 4 "lu")  ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
 214     ("n" 2 "d")  ; INT16 (signed 16-bit integer)
 215     ("q" 2 "u")  ; UINT16 (unsigned 16-bit integer)
 216     ("i" 4 "ld") ; INT32 (signed 32-bit integer)
 217     ("u" 4 "lu") ; UINT32 (unsigned 32-bit integer)
 218     ("x" 8 "Ld") ; INT64 (signed 64-bit integer)
 219     ("t" 8 "Lu") ; UINT64 (unsigned 64-bit integer)
 220     ("d" 8 "lf") ; DOUBLE (64-bit float)
 221     ("h" 4 "lu") ; UINT32 (unix file descriptor)
 222     ("a" ? ?)    ; ARRAY = UINT32 byte-length, items
 223     ("s" ? ?)    ; STRING = length + data + NUL
 224     ("o" ? ?)    ; OBJECT_PATH = BYTE length + data + NUL
 225     ("g" ? ?)    ; SIGNATURE = BYTE length + data + NUL
 226     ("(" ? ?)    ; STRUCT begin in signature = (8-align) + data
 227     (")" 0 ?)    ; STRUCT end in signature
 228     ("v" ? ?)    ; VARIANT = signature + data
 229     ("{" ? ?)    ; DICT_ENTRY begin
 230     ("}" ? ?)    ; DICT_ENTRY end
 231     ("r" ? ?)    ; reserved STRUCT in bindings?
 232     ("e" ? ?)    ; reserved DICT_ENTRY in bindings ?
 233     ("m" ? ?)    ; reserved 'maybe'
 234     ("*" ? ?)    ; reserved 'single complete type'
 235     ("?" ? ?)    ; reserved 'basic type'
 236     ("@" ? ?)    ; reserved
 237     ("&" ? ?)    ; reserved
 238     ("^" ? ?)    ; reserved
 239     )
 240  )
 241
 242 (define (pack-data-item ES DATA)
 243   (if (list? ES) (pack-data-struct ES DATA)
 244     (= ES "s") (pack-data-string ES DATA)
 245     (= ES "o") (pack-data-string ES DATA)
 246     (= ES "g") (pack-data-signature ES DATA)
 247     (= ES "v") (apply pack-data-variant DATA)
 248     (if (lookup ES FMTMAP) (pack-align (pack $it DATA)))))
 249
 250 (define (pack-data-variant ES DATA)
 251   (extend (pack-align (pack "bbb" 1 (char ES) 0) 1)
 252           (pack-data-item ES DATA)))
 253
 254 ;; pack types "s" and "o"
 255 (define (pack-data-string ES DATA)
 256   (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 4))
 257
 258 ;; pack type "g"
 259 (define (pack-data-signature ES DATA)
 260   (pack-align (pack (format "bs%db" (length DATA)) (length DATA) DATA 0) 1))
 261
 262 ;; Pack an array. DATA elements marshalled by repeating ES, preceded
 263 ;; by the array length in bytes as aligned UINT32.
 264 (define (pack-data-array ES DATA)
 265   (let ((PAD (pack-align "" 4))
 266         (X (inc AT 4)) ; start index of array bytes
 267         (DATA (apply extend (map (curry pack-data-item ES) DATA))))
 268     (extend PAD (pack "lu" (- AT X)) DATA)))
 269
 270 ;; Pack a struct. ES and DATA elements marshalled pairwise in order
 271 ;; following an initial8-byte alignment.
 272 (define (pack-data-struct ES DATA)
 273   (if (= "a" (ES 0)) (pack-data-array (ES 1) DATA)
 274     (apply extend (cons (pack-align "" 8)
 275                         (map pack-data-item ES DATA)))))
 276
 277 ;;########## unpacking
 278 ;;
 279 ;; Advance AT to an I multiple.
 280 (define (align-AT I)
 281   (inc AT (% (- I (% AT I)) I)))
 282
 283 ;; Advance AT to an I multiple and unpack (by newlisp format) at that
 284 ;; position in DATA. Then advance AT further past that unpacking but
 285 ;; return the unpacked value.
 286 (define (unpack-align I FMT)
 287   ##(println (list 'unpack-align I FMT AT (length DATA)))
 288   (align-AT I)
 289   ((fn (X) X) ((unpack FMT (AT DATA)) 0) (inc AT I)))
 290
 291 ;; Unpack a string or object path. The format is "lu" (UINT32) with
 292 ;; the string length, then "s%db" with that string length and followed
 293 ;; by a NUL byte.
 294 (define (unpack-data-string ES (N (unpack-align 4 "lu")))
 295   ((fn (X) X) ((unpack (string "s" N) (AT DATA)) 0) (inc AT (+ 1 N))))
 296
 297 ;; Unpack a signature string. The format is "b" (BYTE) with the string
 298 ;; length, then "s%db" with that string length and followed by a NUL
 299 ;; byte. I.e. the same as unpack-data-string but with the string
 300 ;; length in a BYTE rather than an UINT32.
 301 (define (unpack-data-signature ES)
 302   (unpack-data-string ES (unpack-align 1 "b")))
 303
 304 ;; Unpack a variant item. This consists of "bbb" where the middle
 305 ;; character is the type character for the data, preceded by a 1 byte
 306 ;; and followed by a NUL byte. The subsequent data is unpacked
 307 ;; according to that type character.
 308 (define (unpack-data-variant)
 309   (unpack-data-item ((expand-signature (unpack-data-signature "g")) 0)))
 310
 311 ;; Unpack the ES type item from (AT DATA), optionally with
 312 ;; pre-alignment, and increment AT past the padding and item.
 313 (define (unpack-data-item ES)
 314   ##(println (list 'unpack-data-item ES AT (length DATA)))
 315   (if (list? ES) (unpack-data-struct ES)
 316     (= ES "s") (unpack-data-string ES)
 317     (= ES "o") (unpack-data-string ES)
 318     (= ES "g") (unpack-data-signature ES)
 319     (= ES "v") (unpack-data-variant)
 320     (if (assoc ES FMTMAP) (unpack-align ($it -2) ($it -1)))))
 321
 322 ;; Unpack array with ES elements. The array begins with an UINT32
 323 ;; field telling how many bytes to unpack, followed by the array
 324 ;; elements.
 325 (define (unpack-data-array ES)
 326   (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
 327     (when (and (list? ES) (!= "a" (ES 0))) (align-AT 8))
 328     (while (< AT N)
 329       ##(println "---next " (list AT N))
 330       (push (unpack-data-item ES) OUT -1))
 331     OUT))
 332
 333 ;; Unpack a structure or array with ES fields.
 334 (define (unpack-data-struct ES)
 335   ##(println (list 'unpack-data-struct ES AT))
 336   (if (= "a" (ES 0)) (unpack-data-array (ES 1))
 337     (begin (align-AT 8) (map unpack-data-item ES))))
 338
 339 ;; Unpack from a DATA string according to signature SIGN This returns
 340 ;; a pair (unpacked pos) of unpacked data and how much data is
 341 ;; consumed.
 342 (define (unpack-data SIGN DATA (AT 0))
 343   ##(println (format "*** unpack-data %s %d %d" SIGN (length DATA) AT))
 344   (list (unpack-data-item (expand-signature SIGN)) AT))
 345
 346 ;; Unpack all dbus messages in the given DATA block. Each message
 347 ;; consists of head and body. The head has signature "yyyyuua(yv)"
 348 ;; where the array is an alist of key-value pairs, optionally
 349 ;; including the 'SIGNATURE key with the signature for the body; if
 350 ;; omitted, then the body is empty.
 351 ;;
 352 ;; The function returns the header list of key-value pairs optionally
 353 ;; extended with the pair ("" body).
 354 (define (unpack-messages DATA)
 355   (let ((AT 0) (OUT '()) (M nil) (D nil) (S nil))
 356     (while (and (< (+ AT 7) (length DATA))
 357                 (setf M (unpack-data "yyyyuua(yv)" DATA AT)))
 358       (setf AT (M 1))
 359       ##(println "message head " (M 0))
 360       ##(println (list 'remains AT (length DATA)))
 361       (setf M (M 0 -1)) ; Drop all but the headers then map to symbol keys
 362       (dotimes (i (length M))
 363         (setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
 364       ##(println "mapped headers " M)
 365       ;; Add the body, if any, keyed by "".
 366       (setf S (if (lookup 'SIGNATURE M) $it ""))
 367       ##(println (list 'sign S))
 368       (when (and (!= S "") (setf D (unpack-data S DATA AT)))
 369         (setf AT (D 1))
 370         (extend M (list (list "" (D 0)))))
 371       ;; Collate message and move to the next portion in DATA
 372       (push M OUT -1)
 373       ##(println (list 'ending AT (length DATA)))
 374       ;;(align-AT 4)
 375       ##(println (list 'aligned AT (length DATA)))
 376       (setf DATA (AT DATA))
 377       (setf AT 0)
 378       )
 379     OUT ))
 380
 381 #################################################################
 382 ;; Originally lsp-dbus-events.lsp
 383 ;;
 384 ;; This newlisp module implements dbus socket send-receive together
 385 ;; with signal receive. (This file should be loaded into the Dbus
 386 ;; context)
 387 ;;
 388 ;; The REPL loop is re-mastered by means of a prompt-event function
 389 ;; that firstly handles any pending dbus messages, and secondly
 390 ;; net-select on both the dbus socket and stdin.
 391 ;;
 392 ;; Stdin is handled with priority.
 393 ;;
 394 ;; Dbus messages are read and added to the pending list.
 395 ;;
 396 ;; Handlers are set up as functions (fn (data msg) ..) identified by
 397 ;; "dbus callback key" consisting of path, interface, method and
 398 ;; signature separated by ":". For example:
 399 ;;
 400 ;;    "/org/freedesktop/DBus:org.freedesktop.DBus.NameAcquired(s)"
 401 ;;
 402 ;; would identify the handler for the NameAcquired(string) method of
 403 ;; the interface "org.freedesktop.DBus" of the path
 404 ;; "/org/freedesktop/DBus" of the client. That particular callback is
 405 ;; a s.c. signal sent by the dbus framework implementation in reaction
 406 ;; to the initial Hello call, i.e. the s.c. invocation of
 407 ;;
 408 ;;    "/org/freedesktop/DBus:org.freedesktop.DBus.Hello()"
 409 ;;
 410
 411 ;; Return the callback key for a message MSG
 412 (define (message-key MSG)
 413   (string (lookup 'PATH MSG) ":" (lookup 'INTERFACE MSG) "."
 414           (lookup 'MEMBER MSG) "(" (lookup 'SIGNATURE MSG) ")" ))
 415
 416 ;; This is the table of handlers, keyed by path:interface:method:signature
 417 (define RECV:RECV nil)
 418
 419 ;; Utility function to install a handler for a given key,
 420 (define (handler KEY HANDLER)
 421   (RECV (string (%path) ":" KEY) HANDLER))
 422
 423 ;; This is the list of Dbus messages still to handle.
 424 (setf pending '())
 425
 426 (define (no-handler KEY MSG)
 427   (write-line 2 (format "** No handler %s for:\n%s" KEY (string MSG))))
 428
 429 (define (process-message MSG)
 430   (let ((KEY (message-key MSG)))
 431     (if (RECV KEY) ($it (lookup "" MSG))
 432       (no-handler KEY MSG))))
 433
 434 ;; Process all messages currently pending
 435 (define (process-all-pending)
 436   (while (if (pop pending) (process-message $it))))
 437
 438 ;; The main-loop is intended as a prompt-handler so as to deal with
 439 ;; asyncronous events
 440 (define (main-loop S)
 441   (let ((FDS (list 0 (:%socket SYSTEM-BUS))) (FD nil))
 442     (write 2 (string "> "))
 443     (while (or pending (not (member 0 (net-select FDS "r" -1))))
 444       (if (pop pending) (process-message $it)
 445         (if (unpack-messages (or (:read-message SYSTEM-BUS) ""))
 446             (extend pending $it))
 447         ))
 448     "main-loop: "))
 449
 450 (define (human-msg MSG)
 451   (human-bytes (unpack (dup "b" (length MSG)) MSG)))
 452
 453 ;; Send message, then keep reading messages until there is a reply
 454 (define (send-recv-message MSG)
 455   ;;(die nil (list 'send-recv-message (human-msg MSG)))
 456   (net-send (:%socket SYSTEM-BUS) MSG)
 457   (let ((REPLY nil))
 458     (while (nil? REPLY)
 459       (dolist (M (unpack-messages (:read-message SYSTEM-BUS)))
 460         (if (lookup 'REPLY_SERIAL M) (setf REPLY M)
 461           (push M pending -1))))
 462     REPLY))
 463
 464
 465 ;; ====================
 466 ;; Dbus symbols
 467
 468 (constant
 469  'PROTOCOL-VERSION '(1 1)
 470  'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
 471  'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
 472                   NO_AUTO_START
 473                   ALLOW_INTERACTIVE_AUTHORIZATION)
 474  ;; Message headers: [code] => (name type)
 475  'MESSAGE-HEADERS '((INVALID )
 476                     (PATH "o")
 477                     (INTERFACE "s")
 478                     (MEMBER "s")
 479                     (ERROR_NAME "s")
 480                     (REPLY_SERIAL "i")
 481                     (DESTINATION "s")
 482                     (SENDER "s")
 483                     (SIGNATURE "g")
 484                     (UNIX_FDS "i")
 485                     )
 486  )
 487
 488 ;; Map message type symbol to dbus type code (i.e. the list index)
 489 (define (message-type-code TYPE)
 490   (or (find TYPE MESSAGE-TYPES =) 0))
 491
 492 ;; Map flag symbol F to its dbus "bit code"
 493 (define (flag F)
 494   (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
 495
 496 ;; Return the dbus flags code from FLAGS; if it is a number thent tha
 497 ;; is returned as is; if FLAGS is a list of message flag symbols then
 498 ;; combine their codes by bit-OR. Anything else yields 0.
 499 (define (message-flags FLAGS)
 500   (if (number? FLAGS) FLAGS
 501     (list? FLAGS)
 502     (apply | (map flag FLAGS))
 503     0))
 504
 505 ;; (message-header (NAME VALUE))
 506 ; Translate header into its marshalling data. The name is mapped to
 507 ; its header code and associated value type. This gets translated into
 508 ; the marshalling data form of (code (type value))
 509 (define (message-header HDR)
 510   (when (list? HDR)
 511     (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
 512         (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))
 513
 514 ;; Join the excess string arguments N-byte alignment successively
 515 (define (pad-join N)
 516   (let ((OUT ""))
 517     (dolist (S (args))
 518       (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
 519         (extend OUT PAD S)))
 520     OUT))
 521
 522 ;; Return a marshalled message string appended by the marshalled body
 523 (define (message TYPE FLAGS HDRS BODY)
 524   (pad-join 8
 525             (pack-data "yyyyuua(yv)"
 526                        (list (char "l")
 527                              (message-type-code TYPE)
 528                              (message-flags FLAGS)
 529                              (PROTOCOL-VERSION 0) ; Major version code
 530                              (length BODY)
 531                              (connection++)
 532                              (clean null? (map message-header HDRS))))
 533             BODY ))
 534
 535 ;; (:invoke OBJ METHOD ARGS FLAGS)
 536 ; Perform a METHOD_CALL on the (self) object
 537 ;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
 538 ;; "INTERFACE." bit optional. The function returns the list of headers
 539 ;; of the reply message extended with reply value as a faked header
 540 ;; named "".
 541 ;;
 542 ;; This function calls send-recv-message which also polls for signals
 543 ;; until a reply is given, but any such signals are stocked up as
 544 ;; pending for later processing on demand.
 545 (define (invoke METHOD ARGS (FLAGS 0))
 546   (when (regex "((.+):)?((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
 547     (let ((PATH $2) (INTERFACE $4) (MEMBER $5) (SIGNATURE $6))
 548       ;;(println (list 'invoke (%name) INTERFACE MEMBER SIGNATURE))
 549       (if (message 'METHOD_CALL FLAGS
 550                    (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
 551                          (list 'DESTINATION (%name))
 552                          (list 'PATH (if (empty? PATH) (%path) PATH))
 553                          (if (empty? INTERFACE) nil
 554                            (list 'INTERFACE INTERFACE))
 555                          (list 'MEMBER MEMBER)
 556                          (if (empty? SIGNATURE) nil
 557                            (list 'SIGNATURE SIGNATURE))
 558                          )
 559                    (if (empty? SIGNATURE) ""
 560                      (pack-data SIGNATURE ARGS)))
 561           (send-recv-message $it)
 562         nil
 563         ))))
 564
 565 ;; Context variables and framework registration
 566 (setf
 567  SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
 568  APPID (:initialize SYSTEM-BUS)
 569  ROOT (Dbus "/org/freedesktop/DBus")
 570  DBus (DbusInterface "org.freedesktop.DBus")
 571  APPNAME (if (:invoke ROOT (:m DBus "Hello()"))
 572              ($it -1 -1 -1))
 573  )
 574
 575 ;; Installation of some framework notification handlers
 576
 577 ;; Helper method to notify
 578 (define (signal-trace ARGS)
 579   (die nil "** Got:" KEY ARGS ))
 580
 581 (:handler ROOT (:m DBus "NameAcquired(s)") signal-trace)
 582 (:handler ROOT (:m DBus "NameLost(s)") signal-trace)
 583 (:handler ROOT (:m DBus "NameOwnerChanged(sss)") signal-trace)
 584
 585  ; Process notifications that came with the registration handshake
 586 (process-all-pending)
 587
 588 ;; Set up the Dbus event loop as prompt-event handler
 589 (prompt-event Dbus:main-loop)
 590
 591 ;;######################################################################
 592 ;;
 593 ;; Standard interfaces
 594
 595 (context MAIN)
 596
 597 (:use (DbusInterface "org.freedesktop.DBus.Peer"
 598                      '( "Ping():"
 599                         "GetMachineId():s"
 600                         )))
 601
 602 (:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
 603                      '( "GetManagedObjects():a(oa(sa(sv)))"
 604                         )))
 605
 606 (:use (DbusInterface "org.freedesktop.DBus.Introspectable"
 607                      ' Introspectable "Introspect():s" ; (xml data)
 608                        ))
 609 ; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format
 610
 611 (:use (DbusInterface "org.freedesktop.DBus.Properties"
 612                      '( "Get(ss):v"
 613                         "Set(ssv):"
 614                         "GetAll(s):a(sv)"
 615                         "PropertiesChanged(sa(sv)as):" ; signal ?
 616                         )))
 617
 618 (:use (DbusInterface "org.freedesktop.DBus"
 619                      '( "Hello():s"
 620                         "RequestName(su):u"
 621                         "ReleaseName(s):u"
 622                         "ListQueuedOwners (s):as"
 623                         "ListNames():as"
 624                         "ListActivatableNames():as"
 625                         "NameHasOwner(s):b"
 626                         "NameOwnerChanged(sss):" ;  -- signal
 627                         "NameLost(s):" ; -- signal
 628                         "NameAcquired(s):" ; -- signal
 629                         "ActivatableServicesChanged():" ; -- signal
 630                         "StartServiceByName(s,u):u"
 631                         "UpdateActivationEnvironment(a(ss)):"
 632                         "GetNameOwner(s):s"
 633                         "GetConnectionUnixUser(s):u"
 634                         "GetConnectionUnixProcessID(s):u"
 635                         "GetConnectionCredentials(s):a(sv)"
 636                         "GetAdtAuditSessionData(s):ay"
 637                         "GetConnectionSELinuxSecurityContext(s):ay"
 638                         "AddMatch(s):"
 639                         "RemoveMatch(s):"
 640                         "GetId():s"
 641                         "Monitoring.BecomeMonitor(asu):"
 642                         )))
 643
 644 ;eg AddMatch argument:
 645 ;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"
 646
 647 "lsp-dbus.lsp"