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.

6 files changed, 186 insertions, 3 deletions

diff --git a/Makefile.am b/Makefile.am
index d63f2ae4b7b..7049da95946 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -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                               \
diff --git a/configure.ac b/configure.ac
index 6e718afdd1c..307e8b361f9 100644
--- a/configure.ac
+++ b/configure.ac
@@ -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)])
 
diff --git a/doc/guix.texi b/doc/guix.texi
index 07da51f131f..baf6e69039a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index 7a93a790075..8ee2f2d1d46 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -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)
diff --git a/guix/avahi.scm b/guix/avahi.scm
new file mode 100644
index 00000000000..8a82fd3beb0
--- /dev/null
+++ b/guix/avahi.scm
@@ -0,0 +1,167 @@
+;;; 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 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>
+  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)))))
diff --git a/guix/self.scm b/guix/self.scm
index 026dcd9c1a7..257c8eefde6 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -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)))