Initial import
This commit is contained in:
+158
@@ -0,0 +1,158 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Retrieval and parsing of UPnP device-description documents.
|
||||
|
||||
(require net/dns
|
||||
net/url
|
||||
racket/list
|
||||
racket/string
|
||||
xml
|
||||
"private/model.rkt"
|
||||
"private/xml.rkt"
|
||||
"ssdp.rkt")
|
||||
|
||||
(provide upnp-device?
|
||||
upnp-device-udn
|
||||
upnp-device-type
|
||||
upnp-device-friendly-name
|
||||
upnp-device-manufacturer
|
||||
upnp-device-model-name
|
||||
upnp-device-model-number
|
||||
upnp-device-serial-number
|
||||
upnp-device-location
|
||||
upnp-device-address
|
||||
upnp-device-dns-name
|
||||
upnp-device-services
|
||||
upnp-device-embedded-devices
|
||||
upnp-device-property
|
||||
upnp-device-tree
|
||||
upnp-describe)
|
||||
|
||||
(define (upnp-device-type device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-type "upnp-device?" device))
|
||||
(upnp-device-device-type device))
|
||||
|
||||
(define (absolute-url base-url value)
|
||||
(and value
|
||||
(url->string (combine-url/relative base-url value))))
|
||||
|
||||
(define (resolve-dns-name address)
|
||||
(let ([nameserver (dns-find-nameserver)])
|
||||
(and nameserver
|
||||
(with-handlers ([exn:fail? (lambda (_) #f)])
|
||||
(dns-get-name nameserver address)))))
|
||||
|
||||
(define (parse-service value base-url)
|
||||
(upnp-service
|
||||
(xexpr-child-text value "serviceType")
|
||||
(xexpr-child-text value "serviceId")
|
||||
(absolute-url base-url (xexpr-child-text value "SCPDURL"))
|
||||
(absolute-url base-url (xexpr-child-text value "controlURL"))
|
||||
(absolute-url base-url (xexpr-child-text value "eventSubURL"))))
|
||||
|
||||
(define (device-properties value)
|
||||
(for/fold ([properties (hash)])
|
||||
([child (in-list (xexpr-children value))]
|
||||
#:when (xexpr-element? child))
|
||||
(let* ([name (xexpr-local-name (car child))]
|
||||
[text (xexpr-text child #f)])
|
||||
(if (and text
|
||||
(not (member name '("servicelist" "devicelist" "iconlist"))))
|
||||
(hash-set properties name text)
|
||||
properties))))
|
||||
|
||||
(define (parse-device value base-url location address dns-name)
|
||||
(let* ([service-list (xexpr-child-element value "serviceList" #f)]
|
||||
[device-list (xexpr-child-element value "deviceList" #f)]
|
||||
[services
|
||||
(if service-list
|
||||
(for/list ([service (in-list (xexpr-child-elements service-list "service"))])
|
||||
(parse-service service base-url))
|
||||
'())]
|
||||
[embedded-devices
|
||||
(if device-list
|
||||
(for/list ([device (in-list (xexpr-child-elements device-list "device"))])
|
||||
(parse-device device base-url location address dns-name))
|
||||
'())])
|
||||
(upnp-device
|
||||
(xexpr-child-text value "UDN")
|
||||
(xexpr-child-text value "deviceType")
|
||||
(xexpr-child-text value "friendlyName")
|
||||
(xexpr-child-text value "manufacturer")
|
||||
(xexpr-child-text value "modelName")
|
||||
(xexpr-child-text value "modelNumber")
|
||||
(xexpr-child-text value "serialNumber")
|
||||
location
|
||||
address
|
||||
dns-name
|
||||
services
|
||||
embedded-devices
|
||||
(device-properties value))))
|
||||
|
||||
(define (read-description location)
|
||||
(call/input-url
|
||||
(string->url location)
|
||||
(lambda (url)
|
||||
(get-pure-port url '() #:redirections 3))
|
||||
(lambda (in)
|
||||
(xml->xexpr (document-element (read-xml in))))))
|
||||
|
||||
(define (description-base-url description location)
|
||||
(let* ([location-url (string->url location)]
|
||||
[url-base (xexpr-child-text description "URLBase" #f)])
|
||||
(if url-base
|
||||
(combine-url/relative location-url url-base)
|
||||
location-url)))
|
||||
|
||||
;; Return a property from the immediate device element. Property names are
|
||||
;; matched case-insensitively and without an XML namespace prefix.
|
||||
(define (upnp-device-property device name [default #f])
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-property "upnp-device?" device))
|
||||
(unless (or (string? name) (symbol? name))
|
||||
(raise-argument-error 'upnp-device-property "(or/c string? symbol?)" name))
|
||||
(hash-ref (upnp-device-properties device)
|
||||
(string-downcase (if (symbol? name) (symbol->string name) name))
|
||||
default))
|
||||
|
||||
;; Flatten a root device and all embedded devices in document order.
|
||||
(define (upnp-device-tree device)
|
||||
(unless (upnp-device? device)
|
||||
(raise-argument-error 'upnp-device-tree "upnp-device?" device))
|
||||
(cons device
|
||||
(append-map upnp-device-tree
|
||||
(upnp-device-embedded-devices device))))
|
||||
|
||||
;; Download and parse the device description referenced by a group of SSDP
|
||||
;; responses. All responses must point to the same LOCATION.
|
||||
(define (upnp-describe responses #:dns? [dns? #f])
|
||||
(unless (and (list? responses)
|
||||
(pair? responses)
|
||||
(andmap ssdp-response? responses))
|
||||
(raise-argument-error 'upnp-describe
|
||||
"non-empty-list-of-ssdp-response?"
|
||||
responses))
|
||||
(let* ([first-response (car responses)]
|
||||
[location (ssdp-response-location first-response #f)]
|
||||
[address (ssdp-response-address first-response)])
|
||||
(unless location
|
||||
(raise-arguments-error 'upnp-describe
|
||||
"SSDP response has no LOCATION header"
|
||||
"response" first-response))
|
||||
(unless (andmap
|
||||
(lambda (response)
|
||||
(equal? (ssdp-response-location response #f) location))
|
||||
responses)
|
||||
(raise-arguments-error 'upnp-describe
|
||||
"all SSDP responses must have the same LOCATION"
|
||||
"location" location))
|
||||
(let* ([description (read-description location)]
|
||||
[base-url (description-base-url description location)]
|
||||
[device (xexpr-child-element description "device" #f)]
|
||||
[dns-name (and dns? (resolve-dns-name address))])
|
||||
(unless device
|
||||
(raise-arguments-error 'upnp-describe
|
||||
"UPnP description contains no device element"
|
||||
"location" location))
|
||||
(parse-device device base-url location address dns-name))))
|
||||
Reference in New Issue
Block a user