;;
(unless (context? MAIN:FOOP) (load "foop.lsp"))
+(unless (context? MAIN:prog1) (load "misc.lsp"))
(unless (context? MAIN:DbusConnection) (load "lsp-dbus-connection.lsp"))
#################################################################
-(context 'MAIN:Dbus)
+;; The DbusInterface context is used for modelling DBus interfaces.
+;;
+;; It includes in particular the :use method for installing a
+;; DbusInterface FOOP object as a constant named by the interface.
+;; E.g. (:use (DbusInterface "org.freedesktop.DBus.ObjectManager")
+;; installes the constant ObjectManager with a DbusInterface FOOP
+;; object modelling that interface.
+;;
+;; The :m method is used to construct a fullly qualified method name.
+;; E.g. (:m ObjectManager "GetManagedObjects()") assuming the prior
+;; :use installation of ObjectManager results in the fully qualified
+;; name string
+;; "org.freedesktop.DBus.ObjectManager.GetManagedObjects()"
+;;
+(context 'DbusInterface)
+(FOOP name members)
-; Include marshalling functions
-(load "lsp-dbus-marshal.lsp" MAIN:Dbus)
+;; FOOP constructor; remember the interface name
+(define (DbusInterface:DbusInterface NAME (MEMBERS '()))
+ (list (context) NAME MEMBERS))
-;; Declaring the FOOP object
-(FOOP path bus)
+;; Utility method to expand a member with the interface prefix. When
+;; the MEMBER is given without "(", then it is duly looked up in the
+;; MEMBERS list of the DbusInterface, and it thus gets expanded with
+;; parameter signature.
+(define (m MEMBER)
+ (unless (find "(" MEMBER)
+ (if (ref (string MEMBER "(") (%members) (fn (x y) (starts-with y x)) true)
+ (setf MEMBER ((parse $it ":") 0))))
+ (string (%name) "." MEMBER))
+;; Install this interface into the context of the caller
+(define (use)
+ (let ((IF (when (regex "([^.]+)$" (%name) 0) $1))
+ (CC (prefix (first (or (1 (history)) '(MAIN))))))
+ (letex ((S (sym $1 CC)) (V (self)))
+ (begin (context CC) (constant 'S 'V)))))
-(setf SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket"))
-(:initialize SYSTEM-BUS)
+;; Declare additional members for this interface
+(define (has)
+ (dolist (MEMBER (args))
+ (unless (member MEMBER (%members))
+ (!members (push MEMBER (%members) -1)))))
-;; "Constructor". Creates an adapter object for a given base path.
-(define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS))
- (list (context) PATH BUS))
+#################################################################
+(context 'MAIN:Dbus)
+
+;; Declaring the FOOP object
+(FOOP path name bus)
-;; Return the bus name
-(define (bus-name)
- (join (find-all "([^/]+)" (%path) $1 0) "."))
+;; "The FOOP Constructor". Creates an object for a given path.
+(define (Dbus:Dbus PATH (NAME (replace "/" (1 PATH) ".")) (BUS 'SYSTEM-BUS))
+ (list (context) PATH NAME BUS))
-;; Return the DbusConnection connection adapter
-(define (connection)
- (eval (%bus)))
+;; Method to clone a proxy for a given path/object.
+(define (new-path PATH)
+ (list (context) PATH (%name) (%bus)))
+
+;; Update the connection serial and return it
+(define (connection++)
+ (case (%bus)
+ (SYSTEM-BUS (:serial++ SYSTEM-BUS))
+ (true 0)))
+
+; Include marshalling functions and signal handling framework
+(load "lsp-dbus-marshal.lsp" (context))
+(load "lsp-dbus-events.lsp" (context))
;; ====================
-;; Dbus messages
+;; Dbus symbols
(constant
'PROTOCOL-VERSION '(1 1)
'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
NO_AUTO_START
ALLOW_INTERACTIVE_AUTHORIZATION)
- ;; Message headers: [code] (name type)
+ ;; Message headers: [code] => (name type)
'MESSAGE-HEADERS '((INVALID )
(PATH "o")
(INTERFACE "s")
)
)
-;; Determine the type code = index of teh type symbol in the
-;; MESSAGE-TYPES list.
+;; Map message type symbol to dbus type code (i.e. the list index)
(define (message-type-code TYPE)
(or (find TYPE MESSAGE-TYPES =) 0))
+;; Map flag symbol F to its dbus "bit code"
(define (flag F)
(if (find F MESSAGE-FLAGS) (pow 2 $it) 0))
-;; Combining header flag symbols into the flags code = bit-or of the
-;; 2^x values where x is the index for the flag symbol in the
-;; MESSAGE-FLAGS list.
+;; Return the dbus flags code from FLAGS; if it is a number thent tha
+;; is returned as is; if FLAGS is a list of message flag symbols then
+;; combine their codes by bit-OR. Anything else yields 0.
(define (message-flags FLAGS)
(if (number? FLAGS) FLAGS
- (list? FLAGS) (apply | (map flag FLAGS))
+ (list? FLAGS)
+ (apply | (map flag FLAGS))
0))
;; (message-header (NAME VALUE))
; its header code and associated value type. This gets translated into
; the marshalling data form of (code (type value))
(define (message-header HDR)
- (let ((CODE (find (list (HDR 0) '*) MESSAGE-HEADERS match) 0))
- (list CODE (list (MESSAGE-HEADERS CODE 1) (HDR 1)))))
+ (when (list? HDR)
+ (if (find (list (HDR 0) '*) MESSAGE-HEADERS match)
+ (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1))))))
-;; Return a marshalled message
+;; Join the excess string arguments N-byte alignment successively
+(define (pad-join N)
+ (let ((OUT ""))
+ (dolist (S (args))
+ (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
+ (extend OUT PAD S)))
+ OUT))
+
+;; Return a marshalled message string appended by the marshalled body
(define (message TYPE FLAGS HDRS BODY)
(pad-join 8
(pack-data "yyyyuua(yv)"
(message-flags FLAGS)
(PROTOCOL-VERSION 0) ; Major version code
(length BODY)
- (:serial++ (connection))
- (map message-header HDRS)))
- BODY))
-
-(define (method-body ARGS)
- "")
-
-;; Invoke a method on an object via dbus
-; (:invoke OBJ MEMBER INTERFACE FLAGS)
-(define (invoke MEMBER INTERFACE (FLAGS 0))
- (or INTERFACE (setf INTERFACE (bus-name)))
- (if (message 'METHOD_CALL FLAGS
- (list (list 'PATH (%path))
- (list 'DESTINATION (bus-name))
- (list 'INTERFACE INTERFACE)
- (list 'MEMBER MEMBER))
- (method-body (args)))
- (begin
- (let ((MSG $it) (BUFFER "") (RESULT "") (S (:%socket (connection))))
- (net-send S MSG)
- (while (net-select S "r" 1000)
- (net-receive S BUFFER 8192)
- (extend RESULT BUFFER))
- BUFFER))
- nil
- ))
+ (connection++)
+ (clean null? (map message-header HDRS))))
+ BODY ))
+
+;; (:invoke OBJ METHOD ARGS FLAGS)
+; Perform a METHOD_CALL on the (self) object
+;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
+;; "INTERFACE." bit optional. The function returns the list of headers
+;; of the reply message extended with reply value as a faked header
+;; named "".
+;;
+;; This function calls send-recv-message which also polls for signals
+;; until a reply is given, but any such signals are stocked up as
+;; pending for later processing on demand.
+(define (invoke METHOD ARGS (FLAGS 0))
+ (when (regex "((.+):)?((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
+ (let ((PATH $2) (INTERFACE $4) (MEMBER $5) (SIGNATURE $6))
+ ;;(println (list 'invoke (%name) INTERFACE MEMBER SIGNATURE))
+ (if (message 'METHOD_CALL FLAGS
+ (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
+ (list 'DESTINATION (%name))
+ (list 'PATH (if (empty? PATH) (%path) PATH))
+ (if (empty? INTERFACE) nil
+ (list 'INTERFACE INTERFACE))
+ (list 'MEMBER MEMBER)
+ (if (empty? SIGNATURE) nil
+ (list 'SIGNATURE SIGNATURE))
+ )
+ (if (empty? SIGNATURE) ""
+ (pack-data SIGNATURE ARGS)))
+ (send-recv-message $it)
+ nil
+ ))))
+
+;; Context variables and framework registration
+(setf
+ SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
+ APPID (:initialize SYSTEM-BUS)
+ ROOT (Dbus "/org/freedesktop/DBus")
+ DBus (DbusInterface "org.freedesktop.DBus")
+ APPNAME (if (:invoke ROOT (:m DBus "Hello()"))
+ ($it -1 -1 -1))
+ )
+
+;; Installation of some framework notification handlers
+
+;; Helper method to notify
+(define (signal-trace ARGS)
+ (die nil "** Got:" KEY ARGS ))
+
+(:handler ROOT (:m DBus "NameAcquired(s)") signal-trace)
+(:handler ROOT (:m DBus "NameLost(s)") signal-trace)
+(:handler ROOT (:m DBus "NameOwnerChanged(sss)") signal-trace)
+
+ ; Process notifications that came with the registration handshake
+(process-all-pending)
+
+;; Set up the Dbus event loop as prompt-event handler
+(prompt-event Dbus:main-loop)
+
+;;######################################################################
+;;
+;; Standard interfaces
+
+(context MAIN)
+
+(:use (DbusInterface "org.freedesktop.DBus.Peer"
+ '( "Ping():"
+ "GetMachineId():s"
+ )))
+
+(:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
+ '( "GetManagedObjects():a(oa(sa(sv)))"
+ )))
+
+(:use (DbusInterface "org.freedesktop.DBus.Introspectable"
+ ' Introspectable "Introspect():s" ; (xml data)
+ ))
+; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format
+
+(:use (DbusInterface "org.freedesktop.DBus.Properties"
+ '( "Get(ss):v"
+ "Set(ssv):"
+ "GetAll(s):a(sv)"
+ "PropertiesChanged(sa(sv)as):" ; signal ?
+ )))
+
+(:use (DbusInterface "org.freedesktop.DBus"
+ '( "Hello():s"
+ "RequestName(su):u"
+ "ReleaseName(s):u"
+ "ListQueuedOwners (s):as"
+ "ListNames():as"
+ "ListActivatableNames():as"
+ "NameHasOwner(s):b"
+ "NameOwnerChanged(sss):" ; -- signal
+ "NameLost(s):" ; -- signal
+ "NameAcquired(s):" ; -- signal
+ "ActivatableServicesChanged():" ; -- signal
+ "StartServiceByName(s,u):u"
+ "UpdateActivationEnvironment(a(ss)):"
+ "GetNameOwner(s):s"
+ "GetConnectionUnixUser(s):u"
+ "GetConnectionUnixProcessID(s):u"
+ "GetConnectionCredentials(s):a(sv)"
+ "GetAdtAuditSessionData(s):ay"
+ "GetConnectionSELinuxSecurityContext(s):ay"
+ "AddMatch(s):"
+ "RemoveMatch(s):"
+ "GetId():s"
+ "Monitoring.BecomeMonitor(asu):"
+ )))
+
+;eg AddMatch argument:
+;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"
"lsp-dbus.lsp"
projects / rrq / lsp-utils.git / blobdiff