futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add Avahi support.

Browse Source 
* 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.
This commit is contained in:
Mathieu Othacehe 2020-11-22 15:12:17 +01:00
parent 8518a3692c
commit 375cc7dea2
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
6 changed files with 186 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -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 \

6
configure.ac
View File

@ -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)])

1
doc/guix.texi
View File

@ -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

5
gnu/packages/package-management.scm
View File

@ -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)

167
guix/avahi.scm Normal file
View File

@ -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)))))

9
guix/self.scm
View File

@ -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)))