1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (guix avahi)
20 #:use-module (guix records)
21 #:use-module (guix build syscalls)
23 #:use-module (avahi client)
24 #:use-module (avahi client lookup)
25 #:use-module (avahi client publish)
26 #:use-module (srfi srfi-9)
27 #:use-module (ice-9 threads)
28 #:export (avahi-service
32 avahi-service-interface
33 avahi-service-local-address
38 avahi-publish-service-thread
39 avahi-browse-service-thread))
41 (define-record-type* <avahi-service>
42 avahi-service make-avahi-service
44 (name avahi-service-name)
45 (type avahi-service-type)
46 (interface avahi-service-interface)
47 (local-address avahi-service-local-address)
48 (address avahi-service-address)
49 (port avahi-service-port)
50 (txt avahi-service-txt))
52 (define* (avahi-publish-service-thread name
55 (stop-loop? (const #f))
58 "Publish the service TYPE using Avahi, for the given PORT, on all interfaces
59 and for all protocols. Also, advertise the given TXT record list.
61 This procedure starts a new thread running the Avahi event loop. It exits
62 when STOP-LOOP? procedure returns true."
63 (define client-callback
64 (lambda (client state)
65 (when (eq? state client-state/s-running)
66 (let ((group (make-entry-group client (const #t))))
68 add-entry-group-service! group interface/unspecified
69 protocol/unspecified '()
70 name type #f #f port txt)
71 (commit-entry-group group)))))
75 (let* ((poll (make-simple-poll))
76 (client (make-client (simple-poll poll)
78 client-flag/ignore-user-config)
80 (while (not (stop-loop?))
81 (iterate-simple-poll poll timeout))))))
83 (define (interface->ip-address interface)
84 "Return the local IP address of the given INTERFACE."
85 (let* ((socket (socket AF_INET SOCK_STREAM 0))
86 (address (network-interface-address socket interface))
87 (ip (inet-ntop (sockaddr:fam address)
88 (sockaddr:addr address))))
96 (define* (avahi-browse-service-thread proc
102 (timeout (if (eq? stop-loop? never)
105 "Browse services which type is part of the TYPES list, using Avahi. The
106 search is restricted to services with the given FAMILY. Each time a service
107 is found or removed, PROC is called and passed as argument the corresponding
108 AVAHI-SERVICE record. If a service is available on multiple network
109 interfaces, it will only be reported on the first interface found.
111 This procedure starts a new thread running the Avahi event loop. It exits
112 when STOP-LOOP? procedure returns true."
114 ;; Set of Avahi discovered hosts.
117 (define (service-resolver-callback resolver interface protocol event
118 service-name service-type domain
119 host-name address-type address port
121 ;; Handle service resolution events.
122 (cond ((eq? event resolver-event/found)
123 ;; Add the service if the host is unknown. This means that if a
124 ;; service is available on multiple network interfaces for a single
125 ;; host, only the first interface found will be considered.
126 (unless (or (hash-ref %known-hosts service-name)
128 (member lookup-result-flag/local flags)))
129 (let* ((address (inet-ntop family address))
130 (local-address (interface->ip-address interface))
131 (service* (avahi-service
134 (interface interface)
135 (local-address local-address)
139 (hash-set! %known-hosts service-name service*)
140 (proc 'new-service service*)))))
141 (free-service-resolver! resolver))
143 (define (service-browser-callback browser interface protocol event
144 service-name service-type
147 ((eq? event browser-event/new)
148 (make-service-resolver (service-browser-client browser)
150 service-name service-type domain
151 protocol/unspecified '()
152 service-resolver-callback))
153 ((eq? event browser-event/remove)
154 (let ((service (hash-ref %known-hosts service-name)))
156 (proc 'remove-service service)
157 (hash-remove! %known-hosts service-name))))))
159 (define client-callback
160 (lambda (client state)
161 (if (eq? state client-state/s-running)
162 (for-each (lambda (type)
163 (make-service-browser client
164 interface/unspecified
167 service-browser-callback))
170 (let* ((poll (make-simple-poll))
171 (client (make-client (simple-poll poll)
174 (and (client? client)
175 (while (not (stop-loop?))
177 (iterate-simple-poll poll timeout)
178 (iterate-simple-poll poll))))))