[jackhill/guix/guix.git] / guix / avahi.scm

;;; 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* (avahi-browse-service-thread proc
                                      #:key
                                      types
                                      (family AF_INET)
                                      (stop-loop? (const #f))
                                      (timeout 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 (hash-ref %known-hosts service-name)
             (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*)))))
    (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?))
           (iterate-simple-poll poll timeout)))))
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
92	(define* (avahi-browse-service-thread proc
93	#:key
94	types
95	(family AF_INET)
96	(stop-loop? (const #f))
97	(timeout 100))
98	"Browse services which type is part of the TYPES list, using Avahi. The
99	search is restricted to services with the given FAMILY. Each time a service
100	is found or removed, PROC is called and passed as argument the corresponding
101	AVAHI-SERVICE record. If a service is available on multiple network
102	interfaces, it will only be reported on the first interface found.
103
104	This procedure starts a new thread running the Avahi event loop. It exits
105	when STOP-LOOP? procedure returns true."
106	(define %known-hosts
107	;; Set of Avahi discovered hosts.
108	(make-hash-table))
109
110	(define (service-resolver-callback resolver interface protocol event
111	service-name service-type domain
112	host-name address-type address port
113	txt flags)
114	;; Handle service resolution events.
115	(cond ((eq? event resolver-event/found)
116	;; Add the service if the host is unknown. This means that if a
117	;; service is available on multiple network interfaces for a single
118	;; host, only the first interface found will be considered.
119	(unless (hash-ref %known-hosts service-name)
120	(let* ((address (inet-ntop family address))
121	(local-address (interface->ip-address interface))
122	(service* (avahi-service
123	(name service-name)
124	(type service-type)
125	(interface interface)
126	(local-address local-address)
127	(address address)
128	(port port)
129	(txt txt))))
130	(hash-set! %known-hosts service-name service*)
131	(proc 'new-service service*)))))
132	(free-service-resolver! resolver))
133
134	(define (service-browser-callback browser interface protocol event
135	service-name service-type
136	domain flags)
137	(cond
138	((eq? event browser-event/new)
139	(make-service-resolver (service-browser-client browser)
140	interface protocol
141	service-name service-type domain
142	protocol/unspecified '()
143	service-resolver-callback))
144	((eq? event browser-event/remove)
145	(let ((service (hash-ref %known-hosts service-name)))
146	(when service
147	(proc 'remove-service service)
148	(hash-remove! %known-hosts service-name))))))
149
150	(define client-callback
151	(lambda (client state)
152	(if (eq? state client-state/s-running)
153	(for-each (lambda (type)
154	(make-service-browser client
155	interface/unspecified
156	protocol/inet
157	type #f '()
158	service-browser-callback))
159	types))))
160
161	(let* ((poll (make-simple-poll))
162	(client (make-client (simple-poll poll)
163	'() ;; no flags
164	client-callback)))
165	(and (client? client)
166	(while (not (stop-loop?))
167	(iterate-simple-poll poll timeout)))))