summaryrefslogtreecommitdiff
path: root/guix/avahi.scm
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))))))