blob: cb0c85f9f45ceeb99e3587d50ed3d77514afb5d6 (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
;;; 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 never
;; Never true.
(const #f))
(define* (avahi-browse-service-thread proc
#:key
types
(ignore-local? #t)
(family AF_INET)
(stop-loop? never)
(timeout (if (eq? stop-loop? never)
#f
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 (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))))))
|
