racket-upnp/query.rkt

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