Initial import
This commit is contained in:
@@ -0,0 +1,192 @@
|
||||
#lang racket/base
|
||||
|
||||
;; High-level, device-oriented UPnP discovery.
|
||||
;;
|
||||
;; query-upnp-devices hides SSDP response grouping and XML retrieval. Device
|
||||
;; kinds are friendly symbols; the original UPnP device-type URN remains
|
||||
;; available through upnp-device-type.
|
||||
|
||||
(require racket/list
|
||||
racket/string
|
||||
"device.rkt"
|
||||
"ssdp.rkt")
|
||||
|
||||
(provide query-upnp-devices
|
||||
upnp-device-kinds
|
||||
upnp-device?
|
||||
upnp-device-kind
|
||||
upnp-device-name
|
||||
upnp-device-udn
|
||||
upnp-device-address
|
||||
upnp-device-dns-name
|
||||
upnp-device-manufacturer
|
||||
upnp-device-model
|
||||
upnp-device-type
|
||||
upnp-device-services)
|
||||
|
||||
(define-logger upnp)
|
||||
|
||||
(define device-kind-table
|
||||
'((media-renderer
|
||||
"MediaRenderer"
|
||||
"Network players, televisions, speakers, receivers and amplifiers")
|
||||
(media-server
|
||||
"MediaServer"
|
||||
"Media servers, NAS devices and media libraries")
|
||||
(internet-gateway
|
||||
"InternetGatewayDevice"
|
||||
"Routers, modems and residential gateways")
|
||||
(printer
|
||||
"printer"
|
||||
"Network printers")
|
||||
(scanner
|
||||
"scanner"
|
||||
"Network document and image scanners")
|
||||
(basic-device
|
||||
"Basic"
|
||||
"Generic UPnP devices")
|
||||
(remote-ui-client
|
||||
"RemoteUIClientDevice"
|
||||
"Devices displaying a remote user interface")
|
||||
(remote-ui-server
|
||||
"RemoteUIServerDevice"
|
||||
"Devices providing a remote user interface")))
|
||||
|
||||
(define (upnp-device-kinds)
|
||||
(for/list ([entry (in-list device-kind-table)])
|
||||
(cons (car entry) (caddr entry))))
|
||||
|
||||
(define (upnp-device-type-name device)
|
||||
(let ([type (upnp-device-type device)])
|
||||
(and type
|
||||
(let ([match
|
||||
(regexp-match
|
||||
#px"(?i:^urn:[^:]+:device:([^:]+):[0-9]+$)"
|
||||
type)])
|
||||
(and match (cadr match))))))
|
||||
|
||||
(define (device-kind-by-name name)
|
||||
(let ([entry
|
||||
(and name
|
||||
(findf
|
||||
(lambda (candidate)
|
||||
(string-ci=? (cadr candidate) name))
|
||||
device-kind-table))])
|
||||
(if entry (car entry) 'unknown)))
|
||||
|
||||
(define (upnp-device-kind device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-kind "upnp-device?" device))
|
||||
(device-kind-by-name (upnp-device-type-name device)))
|
||||
|
||||
(define (upnp-device-name device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-name "upnp-device?" device))
|
||||
(or (upnp-device-friendly-name device)
|
||||
(upnp-device-model-name device)
|
||||
(upnp-device-address device)))
|
||||
|
||||
(define (upnp-device-model device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-model "upnp-device?" device))
|
||||
(let ([name (upnp-device-model-name device)]
|
||||
[number (upnp-device-model-number device)])
|
||||
(cond
|
||||
[(and name number (not (string-ci=? name number)))
|
||||
(string-append name " (" number ")")]
|
||||
[name name]
|
||||
[number number]
|
||||
[else #f])))
|
||||
|
||||
(define (known-device-kind? kind)
|
||||
(or (eq? kind 'unknown)
|
||||
(ormap (lambda (entry) (eq? (car entry) kind))
|
||||
device-kind-table)))
|
||||
|
||||
(define (normalize-kinds value)
|
||||
(let ([kinds
|
||||
(cond
|
||||
[(or (not value) (eq? value 'all)) #f]
|
||||
[(symbol? value) (list value)]
|
||||
[(and (list? value) (andmap symbol? value))
|
||||
(remove-duplicates value)]
|
||||
[else
|
||||
(raise-argument-error
|
||||
'query-upnp-devices
|
||||
"(or/c 'all symbol? (listof symbol?))"
|
||||
value)])])
|
||||
(when kinds
|
||||
(for ([kind (in-list kinds)])
|
||||
(unless (known-device-kind? kind)
|
||||
(raise-arguments-error
|
||||
'query-upnp-devices
|
||||
"unknown device kind"
|
||||
"kind" kind
|
||||
"known kinds" (map car device-kind-table)))))
|
||||
kinds))
|
||||
|
||||
(define (kind-entry kind)
|
||||
(findf (lambda (entry) (eq? (car entry) kind))
|
||||
device-kind-table))
|
||||
|
||||
(define (search-target kinds)
|
||||
(if (and kinds
|
||||
(= (length kinds) 1)
|
||||
(not (eq? (car kinds) 'unknown)))
|
||||
(let ([entry (kind-entry (car kinds))])
|
||||
(format "urn:schemas-upnp-org:device:~a:1" (cadr entry)))
|
||||
"ssdp:all"))
|
||||
|
||||
(define (description-devices responses dns?)
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exception)
|
||||
(log-upnp-warning
|
||||
"unable to read UPnP description ~a: ~a"
|
||||
(ssdp-response-location (car responses) "<unknown>")
|
||||
(exn-message exception))
|
||||
'())])
|
||||
(upnp-device-tree (upnp-describe responses #:dns? dns?))))
|
||||
|
||||
(define (device-key device)
|
||||
(or (upnp-device-udn device)
|
||||
(list (upnp-device-location device)
|
||||
(upnp-device-type device)
|
||||
(upnp-device-friendly-name device))))
|
||||
|
||||
(define (remove-duplicate-devices devices)
|
||||
(let-values ([(result seen)
|
||||
(for/fold ([result '()]
|
||||
[seen (hash)])
|
||||
([device (in-list devices)])
|
||||
(let ([key (device-key device)])
|
||||
(if (hash-has-key? seen key)
|
||||
(values result seen)
|
||||
(values (cons device result)
|
||||
(hash-set seen key #t)))))])
|
||||
(reverse result)))
|
||||
|
||||
(define (kind-selected? device kinds)
|
||||
(or (not kinds)
|
||||
(member (upnp-device-kind device) kinds)))
|
||||
|
||||
;; Discover devices. With one known kind, a targeted M-SEARCH is used. With
|
||||
;; multiple kinds, 'unknown or 'all, one ssdp:all search is used and the parsed
|
||||
;; device tree is filtered afterwards.
|
||||
(define (query-upnp-devices [kinds-value 'all]
|
||||
#:interface [interface #f]
|
||||
#:dns? [dns? #f])
|
||||
(let* ([kinds (normalize-kinds kinds-value)]
|
||||
[responses
|
||||
(ssdp-discover (search-target kinds)
|
||||
#:interface interface)]
|
||||
[groups (ssdp-group-responses responses)]
|
||||
[devices
|
||||
(append-map
|
||||
(lambda (group)
|
||||
(description-devices group dns?))
|
||||
(hash-values groups))]
|
||||
[selected
|
||||
(filter (lambda (device) (kind-selected? device kinds))
|
||||
devices)])
|
||||
(remove-duplicate-devices selected)))
|
||||
Reference in New Issue
Block a user