234 lines
9.9 KiB
Racket
234 lines
9.9 KiB
Racket
#lang racket/base
|
|
|
|
;; SSDP discovery.
|
|
;;
|
|
;; This low-level module sends an M-SEARCH request and returns the individual
|
|
;; unicast responses. Device descriptions and service descriptions are dealt
|
|
;; with by higher-level modules.
|
|
|
|
(require racket/list
|
|
simple-log
|
|
racket/string
|
|
racket/udp
|
|
"network.rkt")
|
|
|
|
(provide ssdp-response?
|
|
ssdp-response-address
|
|
ssdp-response-port
|
|
ssdp-response-header
|
|
ssdp-response-target
|
|
ssdp-response-usn
|
|
ssdp-response-udn
|
|
ssdp-response-location
|
|
ssdp-group-responses
|
|
ssdp-discover)
|
|
|
|
(sl-def-log upnp-ssdp)
|
|
|
|
(define ssdp-multicast-address "239.255.255.250")
|
|
(define ssdp-multicast-port 1900)
|
|
|
|
(struct ssdp-response
|
|
(address port status headers raw)
|
|
#:transparent)
|
|
|
|
(define (check-discovery-arguments search-target mx timeout repeat interface ttl user-agent)
|
|
(unless (and (string? search-target)
|
|
(not (string=? (string-trim search-target) "")))
|
|
(raise-argument-error 'ssdp-discover "non-empty-string?" search-target))
|
|
(unless (and (exact-integer? mx) (<= 1 mx 5))
|
|
(raise-argument-error 'ssdp-discover "(integer-in 1 5)" mx))
|
|
(unless (and (real? timeout) (positive? timeout) (>= timeout mx))
|
|
(raise-argument-error 'ssdp-discover
|
|
(format "real? greater than or equal to MX (~a)" mx)
|
|
timeout))
|
|
(unless (exact-positive-integer? repeat)
|
|
(raise-argument-error 'ssdp-discover "exact-positive-integer?" repeat))
|
|
(unless (or (not interface) (string? interface))
|
|
(raise-argument-error 'ssdp-discover "(or/c #f string?)" interface))
|
|
(unless (and (exact-integer? ttl) (<= 1 ttl 255))
|
|
(raise-argument-error 'ssdp-discover "(integer-in 1 255)" ttl))
|
|
(unless (or (not user-agent) (string? user-agent))
|
|
(raise-argument-error 'ssdp-discover "(or/c #f string?)" user-agent)))
|
|
|
|
(define (make-search-request search-target mx user-agent)
|
|
(string->bytes/utf-8
|
|
(string-append
|
|
"M-SEARCH * HTTP/1.1\r\n"
|
|
"HOST: " ssdp-multicast-address ":" (number->string ssdp-multicast-port) "\r\n"
|
|
"MAN: \"ssdp:discover\"\r\n"
|
|
"MX: " (number->string mx) "\r\n"
|
|
"ST: " search-target "\r\n"
|
|
(if user-agent
|
|
(string-append "USER-AGENT: " user-agent "\r\n")
|
|
"")
|
|
"\r\n")))
|
|
|
|
(define (parse-headers lines)
|
|
(for/fold ([headers (hash)])
|
|
([line (in-list lines)]
|
|
#:break (string=? line ""))
|
|
(let ([match (regexp-match #px"^([^:]+):[ \t]*(.*)$" line)])
|
|
(if match
|
|
(hash-set headers
|
|
(string-downcase (string-trim (cadr match)))
|
|
(string-trim (caddr match)))
|
|
headers))))
|
|
|
|
(define (parse-response packet address port)
|
|
(let* ([raw (bytes->string/latin-1 packet)]
|
|
[lines (regexp-split #px"\r?\n" raw)]
|
|
[status (if (pair? lines) (string-trim (car lines)) "")])
|
|
(and (regexp-match? #px"^HTTP/1\\.[01][ \t]+200(?:[ \t]|$)" status)
|
|
(ssdp-response address
|
|
port
|
|
status
|
|
(parse-headers (if (pair? lines) (cdr lines) '()))
|
|
raw))))
|
|
|
|
(define (ssdp-response-header response name [default #f])
|
|
(unless (ssdp-response? response)
|
|
(raise-argument-error 'ssdp-response-header "ssdp-response?" response))
|
|
(unless (or (string? name) (symbol? name))
|
|
(raise-argument-error 'ssdp-response-header "(or/c string? symbol?)" name))
|
|
(hash-ref (ssdp-response-headers response)
|
|
(string-downcase (if (symbol? name) (symbol->string name) name))
|
|
default))
|
|
|
|
(define (ssdp-response-target response [default #f])
|
|
(ssdp-response-header response 'st default))
|
|
|
|
(define (ssdp-response-usn response [default #f])
|
|
(ssdp-response-header response 'usn default))
|
|
|
|
(define (ssdp-response-udn response [default #f])
|
|
(let ([usn (ssdp-response-usn response #f)])
|
|
(if usn
|
|
(car (string-split usn "::"))
|
|
default)))
|
|
|
|
(define (ssdp-response-location response [default #f])
|
|
(ssdp-response-header response 'location default))
|
|
|
|
(define (response-key response)
|
|
(list (ssdp-response-address response)
|
|
(ssdp-response-usn response "")
|
|
(ssdp-response-target response "")
|
|
(ssdp-response-location response "")))
|
|
|
|
(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)
|
|
(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)
|
|
(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)]
|
|
[packet (subbytes buffer 0 length)]
|
|
[response (parse-response packet address port)]
|
|
[key (and response (response-key response))])
|
|
(if (or (not response) (hash-has-key? seen key))
|
|
(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.
|
|
(define (ssdp-group-responses responses)
|
|
(unless (and (list? responses) (andmap ssdp-response? responses))
|
|
(raise-argument-error 'ssdp-group-responses
|
|
"(listof ssdp-response?)"
|
|
responses))
|
|
(for/fold ([groups (hash)])
|
|
([response (in-list responses)])
|
|
(let ([location (ssdp-response-location response #f)])
|
|
(if location
|
|
(hash-update groups location
|
|
(lambda (group) (cons response group))
|
|
'())
|
|
groups))))
|
|
|
|
;; Search for a UPnP search target. The default "ssdp:all" returns all
|
|
;; advertised device and service targets. #:interface may be a local IPv4
|
|
;; address such as "10.7.3.118" when the machine has multiple interfaces.
|
|
;; Without #:interface, the local IPv4 address for the SSDP route is detected.
|
|
(define (ssdp-discover [search-target "ssdp:all"]
|
|
#:mx [mx 3]
|
|
#:timeout [timeout #f]
|
|
#:repeat [repeat 3]
|
|
#:interface [interface #f]
|
|
#:ttl [ttl 2]
|
|
#:user-agent [user-agent #f])
|
|
(let* ([effective-timeout (or timeout (+ mx 1.0))]
|
|
[effective-interface
|
|
(or interface
|
|
(with-handlers
|
|
([exn:fail?
|
|
(lambda (exception)
|
|
(warn-upnp-ssdp
|
|
"Could not determine the UPnP IPv4 address: ~a; using the OS-selected interface"
|
|
(exn-message exception))
|
|
#f)])
|
|
(upnp-default-ipv4-address)))])
|
|
(check-discovery-arguments search-target
|
|
mx
|
|
effective-timeout
|
|
repeat
|
|
effective-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 effective-interface "OS-selected") 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 effective-interface 0)
|
|
(dbg-upnp-ssdp
|
|
"SSDP socket bound to local interface ~a"
|
|
(or effective-interface "OS-selected"))
|
|
(udp-multicast-set-interface! socket effective-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.25)))
|
|
(receive-responses socket effective-timeout started-at))
|
|
(lambda ()
|
|
(dbg-upnp-ssdp "Closing SSDP socket")
|
|
(udp-close socket))))))
|