190 lines
7.5 KiB
Racket
190 lines
7.5 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
|
|
racket/string
|
|
racket/udp)
|
|
|
|
(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)
|
|
|
|
(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)
|
|
(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)
|
|
(let ([received (sync/timeout remaining
|
|
(udp-receive!-evt socket buffer))])
|
|
(if (not received)
|
|
(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))
|
|
(loop responses seen)
|
|
(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.
|
|
(define (ssdp-discover [search-target "ssdp:all"]
|
|
#:mx [mx 2]
|
|
#:timeout [timeout #f]
|
|
#:repeat [repeat 2]
|
|
#:interface [interface #f]
|
|
#:ttl [ttl 2]
|
|
#:user-agent [user-agent #f])
|
|
(let ([effective-timeout (or timeout (+ mx 0.5))])
|
|
(check-discovery-arguments search-target
|
|
mx
|
|
effective-timeout
|
|
repeat
|
|
interface
|
|
ttl
|
|
user-agent)
|
|
(let ([socket (udp-open-socket ssdp-multicast-address ssdp-multicast-port)]
|
|
[request (make-search-request search-target mx user-agent)])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(udp-bind! socket interface 0)
|
|
(udp-multicast-set-interface! socket interface)
|
|
(udp-multicast-set-ttl! socket ttl)
|
|
(for ([attempt (in-range repeat)])
|
|
(udp-send-to socket
|
|
ssdp-multicast-address
|
|
ssdp-multicast-port
|
|
request)
|
|
(when (< attempt (sub1 repeat))
|
|
(sleep 0.1)))
|
|
(receive-responses socket effective-timeout))
|
|
(lambda ()
|
|
(udp-close socket))))))
|