Initial import
This commit is contained in:
@@ -0,0 +1,189 @@
|
||||
#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))))))
|
||||
Reference in New Issue
Block a user