Initial import
This commit is contained in:
@@ -0,0 +1,291 @@
|
||||
#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))
|
||||
Reference in New Issue
Block a user