X-Git-Url: https://git.rrq.au/?a=blobdiff_plain;f=lsp-dbus%2Flsp-dbus.lsp;h=dd75d4735f09b768c550c25abe61f9395ed4ed93;hb=63872850e2e6be24bcb3e6f4a84063c936ae88c3;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..dd75d47 100644 --- a/lsp-dbus/lsp-dbus.lsp +++ b/lsp-dbus/lsp-dbus.lsp @@ -11,35 +11,31 @@ ;; (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) -; Include marshalling functions -(load "lsp-dbus-marshal.lsp" MAIN:Dbus) - ;; Declaring the FOOP object -(FOOP path bus) - - -(setf SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")) -(:initialize SYSTEM-BUS) +(FOOP path name bus) -;; "Constructor". Creates an adapter object for a given base path. -(define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS)) - (list (context) PATH BUS)) +;; "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 bus name -(define (bus-name) - (join (find-all "([^/]+)" (%path) $1 0) ".")) +;; Update the connection serial and return it +(define (connection++) + (case (%bus) + (SYSTEM-BUS (:serial++ SYSTEM-BUS)) + (true 0))) -;; Return the DbusConnection connection adapter -(define (connection) - (eval (%bus))) +; 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 +43,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 +57,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 +79,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))))) - -;; Return a marshalled message + (when (list? HDR) + (if (find (list (HDR 0) '*) MESSAGE-HEADERS match) + (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1)))))) + +;; 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 +100,144 @@ (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") + APPNAME (if (lookup "" (:invoke ROOT "org.freedesktop.DBus.Hello()")) + ($it 0)) + ) + +;; Installation of some framework notification handlers + +;; Helper method to notify +(define (signal-trace ARGS) + (die nil "** Got:" KEY ARGS )) + +(:handler ROOT "org.freedesktop.DBus.NameAcquired(s)" signal-trace) +(:handler ROOT "org.freedesktop.DBus.NameLost(s)" signal-trace) +(:handler ROOT "org.freedesktop.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) + +(context 'DbusInterface) +(FOOP name members) + +;; FOOP constructor; remember the interface name +(define (DbusInterface:DbusInterface NAME (MEMBERS '())) + (list (context) NAME MEMBERS)) + +;; Utility method to expand a member with interface prefix +(define (m MEMBER) + (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))))) + +;; Declare additional members for this interface +(define (has) + (dolist (MEMBER (args)) + (unless (member MEMBER (%members)) + (!members (push MEMBER (%members) -1))))) + +;;###################################################################### +;; +;; 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"