From 375cc7dea20da7117c9459e4a4d15144095e015b Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 22 Nov 2020 15:12:17 +0100 Subject: Add Avahi support. * guix/avahi.scm: New file. * Makefile.am (MODULES): Add it. * configure.ac: Add Guile-Avahi dependency. * doc/guix.texi (Requirements): Document it. * gnu/packages/package-management.scm (guix)[native-inputs]: Add "guile-avahi", [propagated-inputs]: ditto. * guix/self.scm (specification->package): Add guile-avahi. (compiled-guix): Ditto. --- guix/avahi.scm | 167 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 167 insertions(+) create mode 100644 guix/avahi.scm (limited to 'guix/avahi.scm') diff --git a/guix/avahi.scm b/guix/avahi.scm new file mode 100644 index 0000000000..8a82fd3beb --- /dev/null +++ b/guix/avahi.scm @@ -0,0 +1,167 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix avahi) + #:use-module (guix records) + #:use-module (guix build syscalls) + #:use-module (avahi) + #:use-module (avahi client) + #:use-module (avahi client lookup) + #:use-module (avahi client publish) + #:use-module (srfi srfi-9) + #:use-module (ice-9 threads) + #:export (avahi-service + avahi-service? + avahi-service-name + avahi-service-type + avahi-service-interface + avahi-service-local-address + avahi-service-address + avahi-service-port + avahi-service-txt + + avahi-publish-service-thread + avahi-browse-service-thread)) + +(define-record-type* + avahi-service make-avahi-service + avahi-service? + (name avahi-service-name) + (type avahi-service-type) + (interface avahi-service-interface) + (local-address avahi-service-local-address) + (address avahi-service-address) + (port avahi-service-port) + (txt avahi-service-txt)) + +(define* (avahi-publish-service-thread name + #:key + type port + (stop-loop? (const #f)) + (timeout 100) + (txt '())) + "Publish the service TYPE using Avahi, for the given PORT, on all interfaces +and for all protocols. Also, advertise the given TXT record list. + +This procedure starts a new thread running the Avahi event loop. It exits +when STOP-LOOP? procedure returns true." + (define client-callback + (lambda (client state) + (when (eq? state client-state/s-running) + (let ((group (make-entry-group client (const #t)))) + (apply + add-entry-group-service! group interface/unspecified + protocol/unspecified '() + name type #f #f port txt) + (commit-entry-group group))))) + + (call-with-new-thread + (lambda () + (let* ((poll (make-simple-poll)) + (client (make-client (simple-poll poll) + (list + client-flag/ignore-user-config) + client-callback))) + (while (not (stop-loop?)) + (iterate-simple-poll poll timeout)))))) + +(define (interface->ip-address interface) + "Return the local IP address of the given INTERFACE." + (let* ((socket (socket AF_INET SOCK_STREAM 0)) + (address (network-interface-address socket interface)) + (ip (inet-ntop (sockaddr:fam address) + (sockaddr:addr address)))) + (close-port socket) + ip)) + +(define* (avahi-browse-service-thread proc + #:key + types + (family AF_INET) + (stop-loop? (const #f)) + (timeout 100)) + "Browse services which type is part of the TYPES list, using Avahi. The +search is restricted to services with the given FAMILY. Each time a service +is found or removed, PROC is called and passed as argument the corresponding +AVAHI-SERVICE record. If a service is available on multiple network +interfaces, it will only be reported on the first interface found. + +This procedure starts a new thread running the Avahi event loop. It exits +when STOP-LOOP? procedure returns true." + (define %known-hosts + ;; Set of Avahi discovered hosts. + (make-hash-table)) + + (define (service-resolver-callback resolver interface protocol event + service-name service-type domain + host-name address-type address port + txt flags) + ;; Handle service resolution events. + (cond ((eq? event resolver-event/found) + ;; Add the service if the host is unknown. This means that if a + ;; service is available on multiple network interfaces for a single + ;; host, only the first interface found will be considered. + (unless (hash-ref %known-hosts service-name) + (let* ((address (inet-ntop family address)) + (local-address (interface->ip-address interface)) + (service* (avahi-service + (name service-name) + (type service-type) + (interface interface) + (local-address local-address) + (address address) + (port port) + (txt txt)))) + (hash-set! %known-hosts service-name service*) + (proc 'new-service service*))))) + (free-service-resolver! resolver)) + + (define (service-browser-callback browser interface protocol event + service-name service-type + domain flags) + (cond + ((eq? event browser-event/new) + (make-service-resolver (service-browser-client browser) + interface protocol + service-name service-type domain + protocol/unspecified '() + service-resolver-callback)) + ((eq? event browser-event/remove) + (let ((service (hash-ref %known-hosts service-name))) + (when service + (proc 'remove-service service) + (hash-remove! %known-hosts service-name)))))) + + (define client-callback + (lambda (client state) + (if (eq? state client-state/s-running) + (for-each (lambda (type) + (make-service-browser client + interface/unspecified + protocol/inet + type #f '() + service-browser-callback)) + types)))) + + (let* ((poll (make-simple-poll)) + (client (make-client (simple-poll poll) + '() ;; no flags + client-callback))) + (and (client? client) + (while (not (stop-loop?)) + (iterate-simple-poll poll timeout))))) -- cgit v1.2.3