#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))))))