Package: guix-patches;
Reported by: Mathieu Othacehe <othacehe <at> gnu.org>
Date: Sun, 22 Nov 2020 15:58:03 UTC
Severity: normal
Tags: patch
Done: Mathieu Othacehe <othacehe <at> gnu.org>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 44802 in the body.
You can then email your comments to 44802 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#44802; Package guix-patches.
(Sun, 22 Nov 2020 15:58:03 GMT) Full text and rfc822 format available.Mathieu Othacehe <othacehe <at> gnu.org>:guix-patches <at> gnu.org.
(Sun, 22 Nov 2020 15:58:03 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: guix-patches <at> gnu.org Cc: Mathieu Othacehe <othacehe <at> gnu.org> Subject: [PATCH 1/2] Add Avahi support. Date: Sun, 22 Nov 2020 16:56:58 +0100
* 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.
---
Makefile.am | 1 +
configure.ac | 6 ++
doc/guix.texi | 1 +
gnu/packages/package-management.scm | 2 +
guix/avahi.scm | 162 ++++++++++++++++++++++++++++
guix/self.scm | 9 +-
6 files changed, 179 insertions(+), 2 deletions(-)
create mode 100644 guix/avahi.scm
diff --git a/Makefile.am b/Makefile.am
index ea43650a14..7c716804c8 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 6e718afdd1..307e8b361f 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 b7f1bc1f00..e2361c25e3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -827,6 +827,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 7ceb7737d8..bc393a8417 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -343,6 +343,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)
@@ -393,6 +394,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 0000000000..fa4a258066
--- /dev/null
+++ b/guix/avahi.scm
@@ -0,0 +1,162 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <othacehe <at> 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-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)
+ (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
+ type
+ (family AF_INET)
+ (stop-loop? (const #f))
+ (timeout 100))
+ "Browse services of the given TYPE and FAMILY using Avahi. Each time a new
+service is found, 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)
+ (interface interface)
+ (local-address local-address)
+ (address address)
+ (port port)
+ (txt txt))))
+ (hash-set! %known-hosts service-name service*)
+ (proc 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)
+ (when (hash-ref %known-hosts service-name)
+ (hash-remove! %known-hosts service-name)))))
+
+ (define client-callback
+ (lambda (client state)
+ (if (eq? state client-state/s-running)
+ (make-service-browser client
+ interface/unspecified
+ protocol/inet
+ type #f '()
+ service-browser-callback))))
+
+ (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 bbfd2f1b95..344dc7c3de 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))
@@ -778,6 +779,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"))
@@ -806,8 +810,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)))
--
2.29.2
Mathieu Othacehe <mathieu <at> cervin.i-did-not-set--mail-host-address--so-tickle-me>
to control <at> debbugs.gnu.org.
(Tue, 24 Nov 2020 13:28:02 GMT) Full text and rfc822 format available.Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Tue, 29 Dec 2020 12:24:04 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.