hans/racket-upnp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

logging added.

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-03 14:11:55 +02:00
parent f51729308c
commit cffedd6dbf
6 changed files with 107 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ssdp.rkt
+41 -11
View File
@@ -7,6 +7,7 @@
;; with by higher-level modules.
(require racket/list
simple-log
racket/string
racket/udp)
@@ -21,6 +22,8 @@
ssdp-group-responses
ssdp-discover)
(sl-def-log upnp-ssdp)
(define ssdp-multicast-address "239.255.255.250")
(define ssdp-multicast-port 1900)
@@ -112,18 +115,29 @@
(ssdp-response-target response "")
(ssdp-response-location response "")))
(define (receive-responses socket timeout)
(define (receive-responses socket timeout started-at)
(dbg-upnp-ssdp "Waiting up to ~a seconds for SSDP responses" timeout)
(let ([buffer (make-bytes 65535)]
[deadline (+ (current-inexact-milliseconds) (* timeout 1000.0))])
(let loop ([responses '()]
[seen (hash)])
(let ([remaining (/ (- deadline (current-inexact-milliseconds)) 1000.0)])
(if (<= remaining 0)
(reverse responses)
(begin
(dbg-upnp-ssdp
"SSDP receive window closed after ~a ms with ~a unique responses"
(inexact->exact (round (- (current-inexact-milliseconds) started-at)))
(length responses))
(reverse responses))
(let ([received (sync/timeout remaining
(udp-receive!-evt socket buffer))])
(if (not received)
(reverse responses)
(begin
(dbg-upnp-ssdp
"SSDP receive timed out after ~a ms with ~a unique responses"
(inexact->exact (round (- (current-inexact-milliseconds) started-at)))
(length responses))
(reverse responses))
(let* ([length (car received)]
[address (cadr received)]
[port (caddr received)]
@@ -131,9 +145,20 @@
[response (parse-response packet address port)]
[key (and response (response-key response))])
(if (or (not response) (hash-has-key? seen key))
(loop responses seen)
(loop (cons response responses)
(hash-set seen key #t)))))))))))
(begin
(when response
(dbg-upnp-ssdp "Ignoring duplicate SSDP response from ~a:~a (~a)" address port (ssdp-response-usn response "unknown USN")))
(loop responses seen))
(begin
(dbg-upnp-ssdp
"Received SSDP response after ~a ms from ~a:~a, target=~a, location=~a"
(inexact->exact (round (- (current-inexact-milliseconds) started-at)))
address
port
(ssdp-response-target response "unknown")
(ssdp-response-location response "unknown"))
(loop (cons response responses)
(hash-set seen key #t))))))))))))
;; Group responses by LOCATION so each device-description document only needs
;; to be downloaded once.
@@ -155,13 +180,13 @@
;; advertised device and service targets. #:interface may be a local IPv4
;; address such as "10.7.3.118" when the machine has multiple interfaces.
(define (ssdp-discover [search-target "ssdp:all"]
#:mx [mx 2]
#:mx [mx 3]
#:timeout [timeout #f]
#:repeat [repeat 2]
#:repeat [repeat 3]
#:interface [interface #f]
#:ttl [ttl 2]
#:user-agent [user-agent #f])
(let ([effective-timeout (or timeout (+ mx 0.5))])
(let ([effective-timeout (or timeout (+ mx 1.0))])
(check-discovery-arguments search-target
mx
effective-timeout
@@ -169,21 +194,26 @@
interface
ttl
user-agent)
(dbg-upnp-ssdp "Starting SSDP discovery target=~a mx=~a timeout=~a repeat=~a interface=~a ttl=~a" search-target mx effective-timeout repeat (or interface "default") ttl)
(let ([socket (udp-open-socket ssdp-multicast-address ssdp-multicast-port)]
[request (make-search-request search-target mx user-agent)])
(dynamic-wind
void
(lambda ()
(define started-at (current-inexact-milliseconds))
(udp-bind! socket interface 0)
(dbg-upnp-ssdp "SSDP socket bound to interface ~a" (or interface "default"))
(udp-multicast-set-interface! socket interface)
(udp-multicast-set-ttl! socket ttl)
(for ([attempt (in-range repeat)])
(dbg-upnp-ssdp "Sending SSDP M-SEARCH attempt ~a of ~a" (add1 attempt) repeat)
(udp-send-to socket
ssdp-multicast-address
ssdp-multicast-port
request)
(when (< attempt (sub1 repeat))
(sleep 0.1)))
(receive-responses socket effective-timeout))
(sleep 0.25)))
(receive-responses socket effective-timeout started-at))
(lambda ()
(dbg-upnp-ssdp "Closing SSDP socket")
(udp-close socket))))))