X-Git-Url: https://git.rrq.au/?a=blobdiff_plain;f=lsp-dbus%2Flsp-dbus.lsp;h=a8109981268bc9e61fdc1dfb03c602ee529a78f3;hb=HEAD;hp=e40c2eb2c02fb75f6df6b34fee5b42c6edea062e;hpb=b803427b65b26ec297322de115e8dcbae55b033e;p=rrq%2Flsp-utils.git diff --git a/lsp-dbus/lsp-dbus.lsp b/lsp-dbus/lsp-dbus.lsp index e40c2eb..a810998 100644 --- a/lsp-dbus/lsp-dbus.lsp +++ b/lsp-dbus/lsp-dbus.lsp @@ -11,35 +11,80 @@ ;; (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) @@ -47,7 +92,7 @@ '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") @@ -61,20 +106,21 @@ ) ) -;; 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)) @@ -82,10 +128,19 @@ ; 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)" @@ -94,31 +149,120 @@ (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"