123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690 |
- (eval-when-compile
- (require 'cl))
- (declare-function dbus-call-method "dbusbind.c")
- (declare-function dbus-register-signal "dbusbind.c")
- (defvar dbus-debug)
- (require 'dbus)
- (defvar zeroconf-debug nil
- "Write messages during service discovery")
- (defconst zeroconf-service-avahi "org.freedesktop.Avahi"
- "The D-Bus name used to talk to Avahi.")
- (defconst zeroconf-path-avahi "/"
- "The D-Bus root object path used to talk to Avahi.")
- (defvar zeroconf-path-avahi-service-type-browser nil
- "The D-Bus object path used to talk to the Avahi service type browser.")
- (defvar zeroconf-path-avahi-service-browser-hash (make-hash-table :test 'equal)
- "The D-Bus object paths used to talk to the Avahi service browser.")
- (defvar zeroconf-path-avahi-service-resolver-hash (make-hash-table :test 'equal)
- "The D-Bus object paths used to talk to the Avahi service resolver.")
- (defconst zeroconf-interface-avahi-entry-group
- (concat zeroconf-service-avahi ".EntryGroup")
- "The D-Bus entry group interface exported by Avahi.")
- (defconst zeroconf-interface-avahi-server
- (concat zeroconf-service-avahi ".Server")
- "The D-Bus server interface exported by Avahi.")
- (defconst zeroconf-interface-avahi-service-type-browser
- (concat zeroconf-service-avahi ".ServiceTypeBrowser")
- "The D-Bus service type browser interface exported by Avahi.")
- (defconst zeroconf-interface-avahi-service-browser
- (concat zeroconf-service-avahi ".ServiceBrowser")
- "The D-Bus service browser interface exported by Avahi.")
- (defconst zeroconf-interface-avahi-service-resolver
- (concat zeroconf-service-avahi ".ServiceResolver")
- "The D-Bus service resolver interface exported by Avahi.")
- (defconst zeroconf-avahi-interface-unspec -1
- "Wildcard Avahi interface spec.")
- (defconst zeroconf-avahi-protocol-unspec -1
- "Wildcard Avahi protocol spec.")
- (defconst zeroconf-avahi-protocol-inet4 0
- "Avahi INET4 address protocol family.")
- (defconst zeroconf-avahi-protocol-inet6 1
- "Avahi INET6 address protocol family.")
- (defconst zeroconf-avahi-domain-unspec ""
- "Empty Avahi domain.")
- (defvar zeroconf-avahi-current-domain zeroconf-avahi-domain-unspec
- "Domain name services are resolved for.")
- (defconst zeroconf-avahi-flags-unspec 0
- "No Avahi flags.")
- (defvar zeroconf-services-hash (make-hash-table :test 'equal)
- "Hash table of discovered Avahi services.
- The key of an entry is the concatenation of the service name and
- service type of a discovered service. The value is the service
- itself. The format of a service is
- \(INTERFACE PROTOCOL NAME TYPE DOMAIN FLAGS\)
- The INTERFACE is a number, which represents the network interface
- the service is located at. The corresponding network interface
- name, like \"eth0\", can be retrieved with the function
- `zeroconf-get-interface-name'.
- PROTOCOL describes the used network protocol family the service
- can be accessed. `zeroconf-avahi-protocol-inet4' means INET4,
- `zeroconf-avahi-protocol-inet6' means INET6. An unspecified
- protocol family is coded with `zeroconf-avahi-protocol-unspec'.
- NAME is the string the service is known at Avahi. A service can
- be known under the same name for different service types.
- Each TYPE stands for a discovered service type of Avahi. The
- format is described in RFC 2782. It is of the form
- \"_APPLICATION-PROTOCOL._TRANSPORT-PROTOCOL\".
- TRANSPORT-PROTOCOL must be either \"tcp\" or \"udp\".
- APPLICATION-PROTOCOL must be a protocol name as specified in URL
- `http://www.dns-sd.org/ServiceTypes.html'. Typical service types
- are \"_workstation._tcp\" or \"_printer._tcp\".
- DOMAIN is the domain name the service is registered in, like \"local\".
- FLAGS, an integer, is used inside Avahi. When publishing a
- service (see `zeroconf-publish-service', the flag 0 is used.")
- (defvar zeroconf-resolved-services-hash (make-hash-table :test 'equal)
- "Hash table of resolved Avahi services.
- The key of an entry is the concatenation of the service name and
- service type of a resolved service. The value is the service
- itself. The format of a service is
- \(INTERFACE PROTOCOL NAME TYPE DOMAIN HOST APROTOCOL ADDRESS PORT TXT FLAGS\)
- INTERFACE, PROTOCOL, NAME, TYPE, DOMAIN and FLAGS have the same
- meaning as in `zeroconf-services-hash'.
- HOST is the host name the service is registered. It is a fully
- qualified name, i.e., it contains DOMAIN.
- APROTOCOL stands for the network protocol family ADDRESS is
- encoded (`zeroconf-avahi-protocol-inet4' means INET4,
- `zeroconf-avahi-protocol-inet6' means INET6). It can be
- different from PROTOCOL, when an address resolution has been
- requested for another protocol family but the default one.
- ADDRESS is the service address, encoded according to the
- APROTOCOL network protocol family. PORT is the corresponding
- port the service can be reached on ADDRESS.
- TXT is an array of strings, describing additional attributes of
- the service. Usually, every string is a key=value pair. The
- supported keys depend on the service type.")
- (defun zeroconf-list-service-names ()
- "Returns all discovered Avahi service names as list."
- (let (result)
- (maphash
- (lambda (key value) (add-to-list 'result (zeroconf-service-name value)))
- zeroconf-services-hash)
- result))
- (defun zeroconf-list-service-types ()
- "Returns all discovered Avahi service types as list."
- (let (result)
- (maphash
- (lambda (key value) (add-to-list 'result (zeroconf-service-type value)))
- zeroconf-services-hash)
- result))
- (defun zeroconf-list-services (type)
- "Returns all discovered Avahi services for a given service type TYPE.
- The service type is one of the returned values of
- `zeroconf-list-service-types'. The return value is a list
- \(SERVICE1 SERVICE2 ...\). See `zeroconf-services-hash' for the
- format of SERVICE."
- (let (result)
- (maphash
- (lambda (key value)
- (when (equal type (zeroconf-service-type value))
- (add-to-list 'result value)))
- zeroconf-services-hash)
- result))
- (defvar zeroconf-service-added-hooks-hash (make-hash-table :test 'equal)
- "Hash table of hooks for newly added services.
- The key of an entry is a service type.")
- (defvar zeroconf-service-removed-hooks-hash (make-hash-table :test 'equal)
- "Hash table of hooks for removed services.
- The key of an entry is a service type.")
- (defun zeroconf-service-add-hook (type event function)
- "Add FUNCTION to the hook of service type TYPE.
- EVENT must be either :new or :removed, indicating whether
- FUNCTION shall be called when a new service has been newly
- detected, or removed.
- FUNCTION must accept one argument SERVICE, which identifies the
- new service. Initially, when EVENT is :new, FUNCTION is called
- for all already detected services of service type TYPE.
- The attributes of SERVICE can be retrieved via the functions
- `zeroconf-service-interface'
- `zeroconf-service-protocol'
- `zeroconf-service-name'
- `zeroconf-service-type'
- `zeroconf-service-domain'
- `zeroconf-service-flags'
- `zeroconf-service-host'
- `zeroconf-service-aprotocol'
- `zeroconf-service-address'
- `zeroconf-service-port'
- `zeroconf-service-txt'"
- (cond
- ((equal event :new)
- (let ((l-hook (gethash type zeroconf-service-added-hooks-hash nil)))
- (add-hook 'l-hook function)
- (puthash type l-hook zeroconf-service-added-hooks-hash)
- (dolist (service (zeroconf-list-services type))
- (funcall function service))))
- ((equal event :removed)
- (let ((l-hook (gethash type zeroconf-service-removed-hooks-hash nil)))
- (add-hook 'l-hook function)
- (puthash type l-hook zeroconf-service-removed-hooks-hash)))
- (t (error "EVENT must be either `:new' or `:removed'"))))
- (defun zeroconf-service-remove-hook (type event function)
- "Remove FUNCTION from the hook of service type TYPE.
- EVENT must be either :new or :removed and has to match the event
- type used when registering FUNCTION."
- (let* ((table (cond
- ((equal event :new)
- zeroconf-service-added-hooks-hash)
- ((equal event :removed)
- zeroconf-service-removed-hooks-hash)
- (t (error "EVENT must be either `:new' or `:removed'"))))
- (l-hook (gethash type table nil)))
- (remove-hook 'l-hook function)
- (if l-hook
- (puthash type l-hook table)
- (remhash type table))))
- (defun zeroconf-get-host ()
- "Returns the local host name as string."
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "GetHostName"))
- (defun zeroconf-get-domain ()
- "Returns the domain name as string."
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "GetDomainName"))
- (defun zeroconf-get-host-domain ()
- "Returns the local host name FQDN as string."
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "GetHostNameFqdn"))
- (defun zeroconf-get-interface-name (number)
- "Return the interface name of internal interface NUMBER."
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "GetNetworkInterfaceNameByIndex"
- :int32 number))
- (defun zeroconf-get-interface-number (name)
- "Return the internal interface number of interface NAME."
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "GetNetworkInterfaceIndexByName"
- name))
- (defun zeroconf-get-service (name type)
- "Return the service description of service NAME as list.
- NAME must be a string. The service must be of service type
- TYPE. The resulting list has the format
- \(INTERFACE PROTOCOL NAME TYPE DOMAIN FLAGS\)."
-
-
- (gethash (concat name "/" type) zeroconf-services-hash nil))
- (defun zeroconf-resolve-service (service)
- "Return all service attributes SERVICE as list.
- NAME must be a string. The service must be of service type
- TYPE. The resulting list has the format
- \(INTERFACE PROTOCOL NAME TYPE DOMAIN HOST APROTOCOL ADDRESS PORT TXT FLAGS\)."
- (let* ((name (zeroconf-service-name service))
- (type (zeroconf-service-type service))
- (key (concat name "/" type)))
- (or
-
- (gethash key zeroconf-resolved-services-hash nil)
-
- (dbus-ignore-errors
- (let* ((result
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "ResolveService"
- zeroconf-avahi-interface-unspec
- zeroconf-avahi-protocol-unspec
- name type
- zeroconf-avahi-current-domain
- zeroconf-avahi-protocol-unspec
- zeroconf-avahi-flags-unspec))
- (elt (nth 9 result)))
-
- (while elt
- (setcar elt (dbus-byte-array-to-string (car elt)))
- (setq elt (cdr elt)))
- (when nil
-
- (let ((object-path (zeroconf-register-service-resolver name type)))
-
- (dolist (member '("Found" "Failure"))
- (dbus-register-signal
- :system zeroconf-service-avahi object-path
- zeroconf-interface-avahi-service-resolver member
- 'zeroconf-service-resolver-handler)))
- )
-
- (puthash key result zeroconf-resolved-services-hash))))))
- (defun zeroconf-service-interface (service)
- "Return the internal interface number of SERVICE."
- (nth 0 service))
- (defun zeroconf-service-protocol (service)
- "Return the protocol number of SERVICE."
- (nth 1 service))
- (defun zeroconf-service-name (service)
- "Return the service name of SERVICE."
- (nth 2 service))
- (defun zeroconf-service-type (service)
- "Return the type name of SERVICE."
- (nth 3 service))
- (defun zeroconf-service-domain (service)
- "Return the domain name of SERVICE."
- (nth 4 service))
- (defun zeroconf-service-flags (service)
- "Return the flags of SERVICE."
- (nth 5 service))
- (defun zeroconf-service-host (service)
- "Return the host name of SERVICE."
- (nth 5 (zeroconf-resolve-service service)))
- (defun zeroconf-service-aprotocol (service)
- "Return the aprotocol number of SERVICE."
- (nth 6 (zeroconf-resolve-service service)))
- (defun zeroconf-service-address (service)
- "Return the IP address of SERVICE."
- (nth 7 (zeroconf-resolve-service service)))
- (defun zeroconf-service-port (service)
- "Return the port number of SERVICE."
- (nth 8 (zeroconf-resolve-service service)))
- (defun zeroconf-service-txt (service)
- "Return the text strings of SERVICE."
- (nth 9 (zeroconf-resolve-service service)))
- (defun zeroconf-init (&optional domain)
- "Instantiate an Avahi service type browser for domain DOMAIN.
- DOMAIN is a string, like \"dns-sd.org\" or \"local\". When
- DOMAIN is nil, the local domain is used."
- (when (and (or (null domain) (stringp domain))
- (dbus-ping :system zeroconf-service-avahi)
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "GetVersionString"))
-
- (setq zeroconf-path-avahi-service-type-browser nil
- zeroconf-avahi-current-domain (or domain
- zeroconf-avahi-domain-unspec))
- (clrhash zeroconf-path-avahi-service-browser-hash)
- (clrhash zeroconf-path-avahi-service-resolver-hash)
- (clrhash zeroconf-services-hash)
- (clrhash zeroconf-resolved-services-hash)
- (clrhash zeroconf-service-added-hooks-hash)
- (clrhash zeroconf-service-removed-hooks-hash)
-
- (let ((object-path (zeroconf-register-service-type-browser)))
-
- (dolist (member '("ItemNew" "ItemRemove" "Failure"))
- (dbus-register-signal
- :system zeroconf-service-avahi object-path
- zeroconf-interface-avahi-service-type-browser member
- 'zeroconf-service-type-browser-handler)))
-
- (dbus-register-signal
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-service-type-browser "StateChanged"
- 'zeroconf-service-type-browser-handler)))
- (defun zeroconf-register-service-type-browser ()
- "Register a service type browser at the Avahi daemon."
- (or zeroconf-path-avahi-service-type-browser
- (setq zeroconf-path-avahi-service-type-browser
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "ServiceTypeBrowserNew"
- zeroconf-avahi-interface-unspec
- zeroconf-avahi-protocol-unspec
- zeroconf-avahi-current-domain
- zeroconf-avahi-flags-unspec))))
- (defun zeroconf-service-type-browser-handler (&rest val)
- "Registered service type browser handler at the Avahi daemon."
- (when zeroconf-debug
- (message "zeroconf-service-type-browser-handler: %s %S"
- (dbus-event-member-name last-input-event) val))
- (cond
- ((string-equal (dbus-event-member-name last-input-event) "ItemNew")
-
-
- (let ((object-path (zeroconf-register-service-browser (nth-value 2 val))))
-
- (dolist (member '("ItemNew" "ItemRemove" "Failure"))
- (dbus-register-signal
- :system zeroconf-service-avahi object-path
- zeroconf-interface-avahi-service-browser member
- 'zeroconf-service-browser-handler))))))
- (defun zeroconf-register-service-browser (type)
- "Register a service browser at the Avahi daemon."
- (or (gethash type zeroconf-path-avahi-service-browser-hash nil)
- (puthash type
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "ServiceBrowserNew"
- zeroconf-avahi-interface-unspec
- zeroconf-avahi-protocol-unspec
- type
- zeroconf-avahi-current-domain
- zeroconf-avahi-flags-unspec)
- zeroconf-path-avahi-service-browser-hash)))
- (defun zeroconf-service-browser-handler (&rest val)
- "Registered service browser handler at the Avahi daemon."
-
- (when zeroconf-debug
- (message "zeroconf-service-browser-handler: %s %S"
- (dbus-event-member-name last-input-event) val))
- (let* ((name (zeroconf-service-name val))
- (type (zeroconf-service-type val))
- (key (concat name "/" type))
- (ahook (gethash type zeroconf-service-added-hooks-hash nil))
- (rhook (gethash type zeroconf-service-removed-hooks-hash nil)))
- (cond
- ((string-equal (dbus-event-member-name last-input-event) "ItemNew")
-
- (puthash key val zeroconf-services-hash)
- (run-hook-with-args 'ahook val))
- ((string-equal (dbus-event-member-name last-input-event) "ItemRemove")
-
- (remhash key zeroconf-services-hash)
- (remhash key zeroconf-resolved-services-hash)
- (run-hook-with-args 'rhook val)))))
- (defun zeroconf-register-service-resolver (name type)
- "Register a service resolver at the Avahi daemon."
- (let ((key (concat name "/" type)))
- (or (gethash key zeroconf-path-avahi-service-resolver-hash nil)
- (puthash key
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "ServiceResolverNew"
- zeroconf-avahi-interface-unspec
- zeroconf-avahi-protocol-unspec
- name type
- zeroconf-avahi-current-domain
- zeroconf-avahi-protocol-unspec
- zeroconf-avahi-flags-unspec)
- zeroconf-resolved-services-hash))))
- (defun zeroconf-service-resolver-handler (&rest val)
- "Registered service resolver handler at the Avahi daemon."
-
-
-
- (let ((elt (nth 9 val)))
- (while elt
- (setcar elt (dbus-byte-array-to-string (car elt)))
- (setq elt (cdr elt))))
- (when zeroconf-debug
- (message "zeroconf-service-resolver-handler: %s %S"
- (dbus-event-member-name last-input-event) val))
- (cond
-
-
- ((string-equal (dbus-event-member-name last-input-event) "Found")
- (puthash
- (concat (zeroconf-service-name val) "/" (zeroconf-service-type val))
- val zeroconf-resolved-services-hash))))
- (defun zeroconf-publish-service (name type domain host port address txt)
- "Publish a service at the Avahi daemon.
- For the description of arguments, see `zeroconf-resolved-services-hash'."
-
- (when (zerop (length name))
- (error "Invalid argument NAME: %s" name))
- (when (zerop (length type))
- (error "Invalid argument TYPE: %s" type))
-
- (when (zerop (length domain))
- (setq domain (zeroconf-get-domain)))
- (when (zerop (length host))
- (setq host (zeroconf-get-host-domain)))
- (when (null port)
- (setq port 0))
-
- (let ((object-path
- (dbus-call-method
- :system zeroconf-service-avahi zeroconf-path-avahi
- zeroconf-interface-avahi-server "EntryGroupNew"))
- result)
-
- (dolist (elt txt)
- (add-to-list 'result (dbus-string-to-byte-array elt)))
-
- (dbus-call-method
- :system zeroconf-service-avahi object-path
- zeroconf-interface-avahi-entry-group "AddService"
- zeroconf-avahi-interface-unspec
- zeroconf-avahi-protocol-unspec
- zeroconf-avahi-flags-unspec
- name type domain host :uint16 port (append '(:array) result))
-
- (unless (zerop (length address))
- (dbus-call-method
- :system zeroconf-service-avahi object-path
- zeroconf-interface-avahi-entry-group "AddAddress"
- zeroconf-avahi-interface-unspec
- zeroconf-avahi-protocol-unspec
- zeroconf-avahi-flags-unspec
- host address))
-
- (dbus-call-method
- :system zeroconf-service-avahi object-path
- zeroconf-interface-avahi-entry-group "Commit")))
- (provide 'zeroconf)
|