292 lines
9.1 KiB
Racket
292 lines
9.1 KiB
Racket
#lang racket/base
|
|
|
|
;; High-level browser for UPnP/DLNA MediaServer devices.
|
|
;;
|
|
;; ContentDirectory returns DIDL-Lite XML. This module turns that XML into
|
|
;; ordinary containers, items and resources, while leaving the raw
|
|
;; ContentDirectory module available for applications that need exact paging
|
|
;; information or vendor-specific fields.
|
|
|
|
(require net/url
|
|
racket/list
|
|
racket/port
|
|
racket/string
|
|
xml
|
|
"device.rkt"
|
|
"private/model.rkt"
|
|
"private/xml.rkt"
|
|
"query.rkt"
|
|
"services/content-directory.rkt")
|
|
|
|
(provide query-media-servers
|
|
media-server?
|
|
media-server-root
|
|
media-server-browse
|
|
media-container-children
|
|
media-server-name
|
|
media-server-address
|
|
media-server-manufacturer
|
|
media-server-model
|
|
get-media-server
|
|
|
|
media-entry?
|
|
media-entry-id
|
|
media-entry-parent-id
|
|
media-entry-title
|
|
media-entry-class
|
|
media-entry-restricted?
|
|
|
|
media-container?
|
|
media-container-child-count
|
|
media-container-searchable?
|
|
|
|
media-item?
|
|
media-item-creator
|
|
media-item-artists
|
|
media-item-album
|
|
media-item-genres
|
|
media-item-date
|
|
media-item-album-art-uri
|
|
media-item-resources
|
|
|
|
media-resource?
|
|
media-resource-uri
|
|
media-resource-protocol-info
|
|
media-resource-content-type
|
|
media-resource-size
|
|
media-resource-duration
|
|
media-resource-bitrate
|
|
media-resource-sample-frequency
|
|
media-resource-bits-per-sample
|
|
media-resource-channels
|
|
media-resource-resolution)
|
|
|
|
(struct media-entry
|
|
(id parent-id title class restricted?)
|
|
#:transparent
|
|
#:constructor-name make-media-entry)
|
|
|
|
(struct media-container media-entry
|
|
(child-count searchable?)
|
|
#:transparent
|
|
#:constructor-name make-media-container)
|
|
|
|
(struct media-item media-entry
|
|
(creator artists album genres date album-art-uri resources)
|
|
#:transparent
|
|
#:constructor-name make-media-item)
|
|
|
|
(struct media-resource
|
|
(uri
|
|
protocol-info
|
|
content-type
|
|
size
|
|
duration
|
|
bitrate
|
|
sample-frequency
|
|
bits-per-sample
|
|
channels
|
|
resolution)
|
|
#:transparent
|
|
#:constructor-name make-media-resource)
|
|
|
|
(define (get-media-server filter-name)
|
|
(let ((fnm (string-downcase (string-trim filter-name))))
|
|
(let ((ms (filter (λ (x)
|
|
(let ((nm (string-downcase (media-server-name x))))
|
|
;(displayln (format "string-contains? '~a' '~a' = ~a" nm fnm (string-contains? nm fnm)))
|
|
(string-contains? nm fnm)))
|
|
(query-media-servers))))
|
|
(if (null? ms)
|
|
#f
|
|
(car ms)))))
|
|
|
|
(define (media-server? value)
|
|
(and (upnp-device? value)
|
|
(eq? (upnp-device-kind value) 'media-server)
|
|
(content-directory? (device-content-directory value))))
|
|
|
|
(define (media-server-name v)
|
|
(and (media-server? v) (upnp-device-name v)))
|
|
|
|
(define (media-server-address v)
|
|
(and (media-server? v) (upnp-device-address v)))
|
|
|
|
(define (media-server-manufacturer v)
|
|
(and (media-server? v) (upnp-device-manufacturer v)))
|
|
|
|
(define (media-server-model v)
|
|
(and (media-server? v) (upnp-device-model v)))
|
|
|
|
(define (check-media-server who value)
|
|
(unless (media-server? value)
|
|
(raise-argument-error who "media-server?" value)))
|
|
|
|
(define (query-media-servers #:interface [interface #f]
|
|
#:dns? [dns? #f])
|
|
(filter media-server?
|
|
(query-upnp-devices 'media-server
|
|
#:interface interface
|
|
#:dns? dns?)))
|
|
|
|
(define (string->boolean value)
|
|
(and value
|
|
(or (string=? value "1")
|
|
(string-ci=? value "true")
|
|
(string-ci=? value "yes"))))
|
|
|
|
(define (string->integer value)
|
|
(and value
|
|
(let ([number (string->number value)])
|
|
(and (exact-integer? number) number))))
|
|
|
|
(define (duration->seconds value)
|
|
(and value
|
|
(let ([match
|
|
(regexp-match
|
|
#px"^([0-9]+):([0-9]{2}):([0-9]{2}(?:[.][0-9]+)?)$"
|
|
value)])
|
|
(and match
|
|
(+ (* 3600 (string->number (cadr match)))
|
|
(* 60 (string->number (caddr match)))
|
|
(string->number (cadddr match)))))))
|
|
|
|
(define (content-type-from-protocol-info value)
|
|
(and value
|
|
(let ([match (regexp-match #px"^[^:]*:[^:]*:([^:]*):" value)])
|
|
(and match
|
|
(not (string=? (cadr match) "*"))
|
|
(cadr match)))))
|
|
|
|
(define (absolute-uri base value)
|
|
(and value
|
|
(with-handlers ([exn:fail? (lambda (_) value)])
|
|
(url->string
|
|
(combine-url/relative (string->url base) value)))))
|
|
|
|
(define (child-texts value name)
|
|
(filter-map
|
|
(lambda (child)
|
|
(xexpr-text child #f))
|
|
(xexpr-child-elements value name)))
|
|
|
|
(define (parse-resource value base-url)
|
|
(let* ([uri (absolute-uri base-url (xexpr-text value #f))]
|
|
[protocol-info (xexpr-attribute value "protocolInfo" #f)])
|
|
(and uri
|
|
(make-media-resource
|
|
uri
|
|
protocol-info
|
|
(content-type-from-protocol-info protocol-info)
|
|
(string->integer (xexpr-attribute value "size" #f))
|
|
(duration->seconds (xexpr-attribute value "duration" #f))
|
|
(string->integer (xexpr-attribute value "bitrate" #f))
|
|
(string->integer (xexpr-attribute value "sampleFrequency" #f))
|
|
(string->integer (xexpr-attribute value "bitsPerSample" #f))
|
|
(string->integer (xexpr-attribute value "nrAudioChannels" #f))
|
|
(xexpr-attribute value "resolution" #f)))))
|
|
|
|
(define (parse-container value)
|
|
(make-media-container
|
|
(xexpr-attribute value "id" #f)
|
|
(xexpr-attribute value "parentID" #f)
|
|
(or (xexpr-child-text value "title" #f) "")
|
|
(xexpr-child-text value "class" #f)
|
|
(string->boolean (xexpr-attribute value "restricted" #f))
|
|
(string->integer (xexpr-attribute value "childCount" #f))
|
|
(string->boolean (xexpr-attribute value "searchable" #f))))
|
|
|
|
(define (parse-item value base-url)
|
|
(make-media-item
|
|
(xexpr-attribute value "id" #f)
|
|
(xexpr-attribute value "parentID" #f)
|
|
(or (xexpr-child-text value "title" #f) "")
|
|
(xexpr-child-text value "class" #f)
|
|
(string->boolean (xexpr-attribute value "restricted" #f))
|
|
(xexpr-child-text value "creator" #f)
|
|
(child-texts value "artist")
|
|
(xexpr-child-text value "album" #f)
|
|
(child-texts value "genre")
|
|
(xexpr-child-text value "date" #f)
|
|
(absolute-uri base-url (xexpr-child-text value "albumArtURI" #f))
|
|
(filter-map
|
|
(lambda (resource)
|
|
(parse-resource resource base-url))
|
|
(xexpr-child-elements value "res"))))
|
|
|
|
(define (parse-entry value base-url)
|
|
(cond
|
|
[(string=? (xexpr-local-name (car value)) "container")
|
|
(parse-container value)]
|
|
[(string=? (xexpr-local-name (car value)) "item")
|
|
(parse-item value base-url)]
|
|
[else #f]))
|
|
|
|
(define (parse-didl-lite content base-url)
|
|
(if (string=? (string-trim content) "")
|
|
'()
|
|
(with-handlers
|
|
([exn:fail?
|
|
(lambda (exception)
|
|
(raise
|
|
(exn:fail
|
|
(format "unable to parse DIDL-Lite: ~a"
|
|
(exn-message exception))
|
|
(current-continuation-marks))))])
|
|
(call-with-input-string
|
|
content
|
|
(lambda (in)
|
|
(let* ([document (read-xml in)]
|
|
[root (xml->xexpr (document-element document))])
|
|
(filter-map
|
|
(lambda (child)
|
|
(and (xexpr-element? child)
|
|
(parse-entry child base-url)))
|
|
(xexpr-children root))))))))
|
|
|
|
(define (container-id value)
|
|
(cond
|
|
[(string? value) value]
|
|
[(media-container? value)
|
|
(or (media-entry-id value)
|
|
(raise-arguments-error
|
|
'media-server-browse
|
|
"media container has no object id"
|
|
"container" value))]
|
|
[else
|
|
(raise-argument-error
|
|
'media-server-browse
|
|
"(or/c string? media-container?)"
|
|
value)]))
|
|
|
|
(define (browse-base-url server)
|
|
(or (upnp-device-location server)
|
|
(format "http://~a/" (upnp-device-address server))))
|
|
|
|
(define (media-server-browse server [container "0"]
|
|
#:start [start 0]
|
|
#:count [count 0])
|
|
(check-media-server 'media-server-browse server)
|
|
(let* ([directory (device-content-directory server)]
|
|
[result
|
|
(content-directory-browse
|
|
directory
|
|
(container-id container)
|
|
#:start start
|
|
#:count count)])
|
|
(parse-didl-lite
|
|
(content-result-content result)
|
|
(browse-base-url server))))
|
|
|
|
(define (media-server-root server #:start [start 0] #:count [count 0])
|
|
(media-server-browse server "0" #:start start #:count count))
|
|
|
|
(define (media-container-children server container
|
|
#:start [start 0]
|
|
#:count [count 0])
|
|
(unless (media-container? container)
|
|
(raise-argument-error 'media-container-children
|
|
"media-container?"
|
|
container))
|
|
(media-server-browse server container #:start start #:count count))
|