guix/avahi.scm

   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 never
  93   ;; Never true.
  94   (const #f))
  95
  96 (define* (avahi-browse-service-thread proc
  97                                       #:key
  98                                       types
  99                                       (ignore-local? #t)
 100                                       (family AF_INET)
 101                                       (stop-loop? never)
 102                                       (timeout (if (eq? stop-loop? never)
 103                                                    #f
 104                                                    100)))
 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.
 126            (unless (or (hash-ref %known-hosts service-name)
 127                        (and ignore-local?
 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
 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
 156           (proc 'remove-service service)
 157           (hash-remove! %known-hosts service-name))))))
 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?))
 176            (if timeout
 177                (iterate-simple-poll poll timeout)
 178                (iterate-simple-poll poll))))))