@@ -73,6 +73,7 @@ include gnu/local.mk
include po/doc/local.mk
MODULES = \
+ guix/avahi.scm \
guix/base16.scm \
guix/base32.scm \
guix/base64.scm \
@@ -161,6 +161,12 @@ if test "x$have_guile_lzlib" != "xyes"; then
AC_MSG_ERROR([Guile-lzlib is missing; please install it.])
fi
+dnl Check for Guile-Avahi.
+GUILE_MODULE_AVAILABLE([have_guile_avahi], [(avahi)])
+if test "x$have_guile_avahi" != "xyes"; then
+ AC_MSG_ERROR([Guile-Avahi is missing; please install it.])
+fi
+
dnl Guile-newt is used by the graphical installer.
GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)])
@@ -829,6 +829,7 @@ Guile,, gnutls-guile, GnuTLS-Guile});
or later;
@item @uref{https://notabug.org/guile-zlib/guile-zlib, Guile-zlib};
@item @uref{https://notabug.org/guile-lzlib/guile-lzlib, Guile-lzlib};
+@item @uref{https://www.nongnu.org/guile-avahi/, Guile-Avahi};
@item
@c FIXME: Specify a version number once a release has been made.
@uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, version 0.3.0
@@ -294,6 +294,7 @@ $(prefix)/etc/init.d\n")))
(guile ,@(if (%current-target-system)
'((assoc-ref native-inputs "guile"))
'((assoc-ref inputs "guile"))))
+ (avahi (assoc-ref inputs "guile-avahi"))
(gcrypt (assoc-ref inputs "guile-gcrypt"))
(json (assoc-ref inputs "guile-json"))
(sqlite (assoc-ref inputs "guile-sqlite3"))
@@ -305,7 +306,7 @@ $(prefix)/etc/init.d\n")))
(ssh (assoc-ref inputs "guile-ssh"))
(gnutls (assoc-ref inputs "gnutls"))
(locales (assoc-ref inputs "glibc-utf8-locales"))
- (deps (list gcrypt json sqlite gnutls
+ (deps (list avahi gcrypt json sqlite gnutls
git bs ssh zlib lzlib))
(effective
(read-line
@@ -349,6 +350,7 @@ $(prefix)/etc/init.d\n")))
;; cross-compilation.
("guile" ,guile-3.0-latest) ;for faster builds
("gnutls" ,gnutls)
+ ("guile-avahi" ,guile-avahi)
("guile-gcrypt" ,guile-gcrypt)
("guile-json" ,guile-json-4)
("guile-sqlite3" ,guile-sqlite3)
@@ -399,6 +401,7 @@ $(prefix)/etc/init.d\n")))
("glibc-utf8-locales" ,glibc-utf8-locales)))
(propagated-inputs
`(("gnutls" ,(if (%current-target-system) gnutls-3.6.14 gnutls))
+ ("guile-avahi" ,guile-avahi)
("guile-gcrypt" ,guile-gcrypt)
("guile-json" ,guile-json-4)
("guile-sqlite3" ,guile-sqlite3)
new file mode 100644
@@ -0,0 +1,170 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix avahi)
+ #:use-module (guix records)
+ #:use-module (guix ui)
+ #:use-module (guix build syscalls)
+ #:use-module (avahi)
+ #:use-module (avahi client)
+ #:use-module (avahi client lookup)
+ #:use-module (avahi client publish)
+ #: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>
+ 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 ((address
+ (network-interface-address
+ (socket AF_INET SOCK_STREAM 0) interface)))
+ (inet-ntop (sockaddr:fam address) (sockaddr:addr address))))
+
+(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)
+ (info (G_ "resolved service `~a' at `~a:~a'~%")
+ service-name (inet-ntop family address) port)
+ ;; 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*))))
+ ((eq? event resolver-event/failure)
+ (report-error (G_ "failed to resolve service `~a'~%")
+ service-name)))
+ (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)))))
@@ -50,6 +50,7 @@
(module-ref (resolve-interface module) variable))))
(match-lambda
("guile" (ref '(gnu packages guile) 'guile-3.0/libgc-7))
+ ("guile-avahi" (ref '(gnu packages guile) 'guile-avahi))
("guile-json" (ref '(gnu packages guile) 'guile-json-4))
("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
("guile-git" (ref '(gnu packages guile) 'guile-git))
@@ -784,6 +785,9 @@ Info manual."
(xz (specification->package "xz"))
(guix (specification->package "guix")))
"Return a file-like object that contains a compiled Guix."
+ (define guile-avahi
+ (specification->package "guile-avahi"))
+
(define guile-json
(specification->package "guile-json"))
@@ -812,8 +816,9 @@ Info manual."
(match (append-map (lambda (package)
(cons (list "x" package)
(package-transitive-propagated-inputs package)))
- (list guile-gcrypt gnutls guile-git guile-json
- guile-ssh guile-sqlite3 guile-zlib guile-lzlib))
+ (list guile-gcrypt gnutls guile-git guile-avahi
+ guile-json guile-ssh guile-sqlite3 guile-zlib
+ guile-lzlib))
(((labels packages _ ...) ...)
packages)))