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:DbusConnection) (load "lsp-dbus-connection.lsp"))
  15
  16 #################################################################
  17 (context 'MAIN:Dbus)
  18
  19 ; Include marshalling functions
  20 (load "lsp-dbus-marshal.lsp" MAIN:Dbus)
  21
  22 ;; Declaring the FOOP object
  23 (FOOP path bus)
  24
  25
  26 (setf SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket"))
  27 (:initialize SYSTEM-BUS)
  28
  29 ;; "Constructor". Creates an adapter object for a given base path.
  30 (define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS))
  31   (list (context) PATH BUS))
  32
  33 ;; Return the bus name
  34 (define (bus-name)
  35   (join (find-all "([^/]+)" (%path) $1 0) "."))
  36
  37 ;; Return the DbusConnection connection adapter
  38 (define (connection)
  39   (eval (%bus)))
  40
  41 ;; ====================
  42 ;; Dbus messages
  43
  44 (constant
  45  'PROTOCOL-VERSION '(1 1)
  46  'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
  47  'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
  48                   NO_AUTO_START
  49                   ALLOW_INTERACTIVE_AUTHORIZATION)
  50  ;; Message headers: [code] (name type)
  51  'MESSAGE-HEADERS '((INVALID )
  52                     (PATH "o")
  53                     (INTERFACE "s")
  54                     (MEMBER "s")
  55                     (ERROR_NAME "s")
  56                     (REPLY_SERIAL "i")
  57                     (DESTINATION "s")
  58                     (SENDER "s")
  59                     (SIGNATURE "g")
  60                     (UNIX_FDS "i")
  61                     )
  62  )
  63
  64 ;; Determine the type code = index of teh type symbol in the
  65 ;; MESSAGE-TYPES list.
  66 (define (message-type-code TYPE)
  67   (or (find TYPE MESSAGE-TYPES =) 0))
  68
  69 (define (flag F)
  70   (if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
  71
  72 ;; Combining header flag symbols into the flags code = bit-or of the
  73 ;; 2^x values where x is the index for the flag symbol in the
  74 ;; MESSAGE-FLAGS list.
  75 (define (message-flags FLAGS)
  76   (if (number? FLAGS) FLAGS
  77     (list? FLAGS) (apply | (map flag FLAGS))
  78     0))
  79
  80 ;; (message-header (NAME VALUE))
  81 ; Translate header into its marshalling data. The name is mapped to
  82 ; its header code and associated value type. This gets translated into
  83 ; the marshalling data form of (code (type value))
  84 (define (message-header HDR)
  85   (let ((CODE (find (list (HDR 0) '*) MESSAGE-HEADERS match) 0))
  86     (list CODE (list (MESSAGE-HEADERS CODE 1) (HDR 1)))))
  87
  88 ;; Return a marshalled message
  89 (define (message TYPE FLAGS HDRS BODY)
  90   (pad-join 8
  91             (pack-data "yyyyuua(yv)"
  92                        (list (char "l")
  93                              (message-type-code TYPE)
  94                              (message-flags FLAGS)
  95                              (PROTOCOL-VERSION 0) ; Major version code
  96                              (length BODY)
  97                              (:serial++ (connection))
  98                              (map message-header HDRS)))
  99             BODY))
 100
 101 (define (method-body ARGS)
 102   "")
 103
 104 ;; Invoke a method on an object via dbus
 105 ; (:invoke OBJ MEMBER INTERFACE FLAGS)
 106 (define (invoke MEMBER INTERFACE (FLAGS 0))
 107   (or INTERFACE (setf INTERFACE (bus-name)))
 108   (if (message 'METHOD_CALL FLAGS
 109                (list (list 'PATH (%path))
 110                      (list 'DESTINATION (bus-name))
 111                      (list 'INTERFACE INTERFACE)
 112                      (list 'MEMBER MEMBER))
 113                (method-body (args)))
 114       (begin
 115         (let ((MSG $it) (BUFFER "") (RESULT "") (S (:%socket (connection))))
 116           (net-send S MSG)
 117           (while (net-select S "r" 1000)
 118             (net-receive S BUFFER 8192)
 119             (extend RESULT BUFFER))
 120           BUFFER))
 121     nil
 122     ))
 123
 124 "lsp-dbus.lsp"