racket-upnp/device.rkt

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