Commit | Line | Data |
---|---|---|
375cc7de MO |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
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. | |
10 | ;;; | |
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. | |
15 | ;;; | |
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/>. | |
18 | ||
19 | (define-module (guix avahi) | |
20 | #:use-module (guix records) | |
21 | #:use-module (guix build syscalls) | |
22 | #:use-module (avahi) | |
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 | |
29 | avahi-service? | |
30 | avahi-service-name | |
31 | avahi-service-type | |
32 | avahi-service-interface | |
33 | avahi-service-local-address | |
34 | avahi-service-address | |
35 | avahi-service-port | |
36 | avahi-service-txt | |
37 | ||
38 | avahi-publish-service-thread | |
39 | avahi-browse-service-thread)) | |
40 | ||
41 | (define-record-type* <avahi-service> | |
42 | avahi-service make-avahi-service | |
43 | 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)) | |
51 | ||
52 | (define* (avahi-publish-service-thread name | |
53 | #:key | |
54 | type port | |
55 | (stop-loop? (const #f)) | |
56 | (timeout 100) | |
57 | (txt '())) | |
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. | |
60 | ||
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)))) | |
67 | (apply | |
68 | add-entry-group-service! group interface/unspecified | |
69 | protocol/unspecified '() | |
70 | name type #f #f port txt) | |
71 | (commit-entry-group group))))) | |
72 | ||
73 | (call-with-new-thread | |
74 | (lambda () | |
75 | (let* ((poll (make-simple-poll)) | |
76 | (client (make-client (simple-poll poll) | |
77 | (list | |
78 | client-flag/ignore-user-config) | |
79 | client-callback))) | |
80 | (while (not (stop-loop?)) | |
81 | (iterate-simple-poll poll timeout)))))) | |
82 | ||
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)))) | |
89 | (close-port socket) | |
90 | ip)) | |
91 | ||
f9978346 LC |
92 | (define never |
93 | ;; Never true. | |
94 | (const #f)) | |
95 | ||
375cc7de MO |
96 | (define* (avahi-browse-service-thread proc |
97 | #:key | |
98 | types | |
0faef871 | 99 | (ignore-local? #t) |
375cc7de | 100 | (family AF_INET) |
f9978346 LC |
101 | (stop-loop? never) |
102 | (timeout (if (eq? stop-loop? never) | |
103 | #f | |
104 | 100))) | |
375cc7de MO |
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. | |
110 | ||
111 | This procedure starts a new thread running the Avahi event loop. It exits | |
112 | when STOP-LOOP? procedure returns true." | |
113 | (define %known-hosts | |
114 | ;; Set of Avahi discovered hosts. | |
115 | (make-hash-table)) | |
116 | ||
117 | (define (service-resolver-callback resolver interface protocol event | |
118 | service-name service-type domain | |
119 | host-name address-type address port | |
120 | txt flags) | |
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. | |
0faef871 MO |
126 | (unless (or (hash-ref %known-hosts service-name) |
127 | (and ignore-local? | |
128 | (member lookup-result-flag/local flags))) | |
375cc7de MO |
129 | (let* ((address (inet-ntop family address)) |
130 | (local-address (interface->ip-address interface)) | |
131 | (service* (avahi-service | |
132 | (name service-name) | |
133 | (type service-type) | |
134 | (interface interface) | |
135 | (local-address local-address) | |
136 | (address address) | |
137 | (port port) | |
138 | (txt txt)))) | |
139 | (hash-set! %known-hosts service-name service*) | |
140 | (proc 'new-service service*))))) | |
141 | (free-service-resolver! resolver)) | |
142 | ||
143 | (define (service-browser-callback browser interface protocol event | |
144 | service-name service-type | |
145 | domain flags) | |
146 | (cond | |
147 | ((eq? event browser-event/new) | |
148 | (make-service-resolver (service-browser-client browser) | |
149 | interface protocol | |
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))) | |
155 | (when service | |
0faef871 MO |
156 | (proc 'remove-service service) |
157 | (hash-remove! %known-hosts service-name)))))) | |
375cc7de MO |
158 | |
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 | |
165 | protocol/inet | |
166 | type #f '() | |
167 | service-browser-callback)) | |
168 | types)))) | |
169 | ||
170 | (let* ((poll (make-simple-poll)) | |
171 | (client (make-client (simple-poll poll) | |
172 | '() ;; no flags | |
173 | client-callback))) | |
174 | (and (client? client) | |
175 | (while (not (stop-loop?)) | |
f9978346 LC |
176 | (if timeout |
177 | (iterate-simple-poll poll timeout) | |
178 | (iterate-simple-poll poll)))))) |