;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; 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 . (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 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))))))