patched-guix/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 never
  ;; Never true.
  (const #f))

(define* (avahi-publish-service-thread name
                                       #:key
                                       type port
                                       (stop-loop? never)
                                       (timeout (if (eq? stop-loop? never)
                                                    #f
                                                    500))
                                       (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?))
         (if timeout
             (iterate-simple-poll poll timeout)
             (iterate-simple-poll poll)))))))

(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
                                      (ignore-local? #t)
                                      (family AF_INET)
                                      (stop-loop? never)
                                      (timeout (if (eq? stop-loop? never)
                                                   #f
                                                   500)))
  "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))))))