191 lines
7.9 KiB
Scheme
191 lines
7.9 KiB
Scheme
;;; 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 never
|
|
;; Never true.
|
|
(const #f))
|
|
|
|
(define* (avahi-publish-service-thread name
|
|
#:key
|
|
type port
|
|
(stop-loop? never)
|
|
(timeout (if (eq? stop-loop? never)
|
|
#f
|
|
500))
|
|
(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?))
|
|
(if timeout
|
|
(iterate-simple-poll poll timeout)
|
|
(iterate-simple-poll poll)))))))
|
|
|
|
(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
|
|
(ignore-local? #t)
|
|
(family AF_INET)
|
|
(stop-loop? never)
|
|
(timeout (if (eq? stop-loop? never)
|
|
#f
|
|
500)))
|
|
"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 (or (hash-ref %known-hosts service-name)
|
|
(and ignore-local?
|
|
(member lookup-result-flag/local flags)))
|
|
(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)
|
|
;; Failure to resolve the host associated with a service. This
|
|
;; usually means that the mDNS record hasn't expired yet but that
|
|
;; the host went off-line.
|
|
(let ((service (hash-ref %known-hosts service-name)))
|
|
(when service
|
|
(proc 'remove-service service)
|
|
(hash-remove! %known-hosts 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?))
|
|
(if timeout
|
|
(iterate-simple-poll poll timeout)
|
|
(iterate-simple-poll poll))))))
|