diff --git a/.gitignore b/.gitignore
index ba0ccfd..583cef4 100644
--- a/.gitignore
+++ b/.gitignore
@@ -19,3 +19,4 @@ compiled/
/scribblings/*.css
/scribblings/*.js
/scribblings/*.html
+/doc
diff --git a/main.rkt b/main.rkt
index 3d6912b..3f51dba 100644
--- a/main.rkt
+++ b/main.rkt
@@ -6,6 +6,7 @@
"query.rkt"
"service.rkt"
"didl-lite.rkt"
+ "resource-capabilities.rkt"
"media-renderer.rkt"
"media-server.rkt"
"media-file-server.rkt")
@@ -16,6 +17,7 @@
"query.rkt"
"service.rkt"
"didl-lite.rkt"
+ "resource-capabilities.rkt"
"media-renderer.rkt"
"media-server.rkt"
"media-file-server.rkt"))
diff --git a/media-renderer.rkt b/media-renderer.rkt
index 29c304a..d075537 100644
--- a/media-renderer.rkt
+++ b/media-renderer.rkt
@@ -9,7 +9,9 @@
(require racket/list
racket/string
"device.rkt"
+ "didl-lite.rkt"
"query.rkt"
+ "resource-capabilities.rkt"
"service.rkt"
"services/av-transport.rkt"
"services/rendering-control.rkt")
@@ -22,9 +24,11 @@
media-renderer-model
get-media-renderer
media-renderer-dlna?
+ media-renderer-play-resource!
media-renderer-play-uri!
media-renderer-play!
media-renderer-next-uri-supported?
+ media-renderer-set-next-resource!
media-renderer-set-next-uri!
media-renderer-pause!
media-renderer-stop!
@@ -126,6 +130,43 @@
"renderer" (upnp-device-name renderer)))
(av-transport-set-next-uri! transport uri #:metadata metadata)))
+(define (resource-metadata uri protocol-info mime-type
+ title artist album genre year track duration size)
+ (didl-lite-audio-item
+ uri
+ #:protocol-info
+ (resolve-dlna-resource-protocol-info
+ uri
+ #:protocol-info protocol-info
+ #:mime-type mime-type)
+ #:title title
+ #:artist artist
+ #:album album
+ #:genre genre
+ #:year year
+ #:track track
+ #:duration duration
+ #:size size))
+
+(define (media-renderer-set-next-resource!
+ renderer uri
+ #:protocol-info [protocol-info #f]
+ #:mime-type [mime-type #f]
+ #:title [title "Media"]
+ #:artist [artist #f]
+ #:album [album #f]
+ #:genre [genre #f]
+ #:year [year #f]
+ #:track [track #f]
+ #:duration [duration #f]
+ #:size [size #f])
+ (media-renderer-set-next-uri!
+ renderer
+ uri
+ #:metadata
+ (resource-metadata uri protocol-info mime-type
+ title artist album genre year track duration size)))
+
;; Start a resource and optionally preload the following resource before
;; playback starts. Setting the next URI first gives the renderer the maximum
;; amount of time to buffer it.
@@ -152,6 +193,25 @@
#:metadata next-metadata))
(av-transport-play! transport)))
+(define (media-renderer-play-resource!
+ renderer uri
+ #:protocol-info [protocol-info #f]
+ #:mime-type [mime-type #f]
+ #:title [title "Media"]
+ #:artist [artist #f]
+ #:album [album #f]
+ #:genre [genre #f]
+ #:year [year #f]
+ #:track [track #f]
+ #:duration [duration #f]
+ #:size [size #f])
+ (media-renderer-play-uri!
+ renderer
+ uri
+ #:metadata
+ (resource-metadata uri protocol-info mime-type
+ title artist album genre year track duration size)))
+
(define (media-renderer-pause! renderer)
(av-transport-pause!
(required-service 'media-renderer-pause! renderer 'av-transport)))
diff --git a/media-server.rkt b/media-server.rkt
index cb589dc..902fe2b 100644
--- a/media-server.rkt
+++ b/media-server.rkt
@@ -46,6 +46,7 @@
media-item-album
media-item-genres
media-item-date
+ media-item-original-track-number
media-item-album-art-uri
media-item-resources
@@ -72,7 +73,8 @@
#:constructor-name make-media-container)
(struct media-item media-entry
- (creator artists album genres date album-art-uri resources)
+ (creator artists album genres date original-track-number
+ album-art-uri resources)
#:transparent
#:constructor-name make-media-item)
@@ -208,6 +210,8 @@
(xexpr-child-text value "album" #f)
(child-texts value "genre")
(xexpr-child-text value "date" #f)
+ (string->integer
+ (xexpr-child-text value "originalTrackNumber" #f))
(absolute-uri base-url (xexpr-child-text value "albumArtURI" #f))
(filter-map
(lambda (resource)
diff --git a/query.rkt b/query.rkt
index 7648ddf..b66546b 100644
--- a/query.rkt
+++ b/query.rkt
@@ -150,7 +150,9 @@
(upnp-device-tree (upnp-describe responses #:dns? dns?))))
(define (device-key device)
- (or (upnp-device-udn device)
+ (or (and (upnp-device-udn device)
+ (list (upnp-device-udn device)
+ (upnp-device-type device)))
(list (upnp-device-location device)
(upnp-device-type device)
(upnp-device-friendly-name device))))
diff --git a/resource-capabilities.rkt b/resource-capabilities.rkt
new file mode 100644
index 0000000..6bb6a8d
--- /dev/null
+++ b/resource-capabilities.rkt
@@ -0,0 +1,200 @@
+#lang racket/base
+
+;; Resolve DLNA resource capabilities advertised by an HTTP media server.
+
+(require net/http-client
+ net/url
+ racket/match
+ racket/port
+ racket/string
+ simple-log)
+
+(provide resolve-dlna-resource-protocol-info
+ clear-dlna-resource-capability-cache!)
+
+(sl-def-log upnp-resource)
+
+(define capability-cache (make-hash))
+(define capability-cache-lock (make-semaphore 1))
+
+(define (clear-dlna-resource-capability-cache!)
+ (call-with-semaphore
+ capability-cache-lock
+ (lambda () (hash-clear! capability-cache))))
+
+(define (url-request-target value)
+ (let* ([relative
+ (struct-copy url value
+ [scheme #f]
+ [user #f]
+ [host #f]
+ [port #f]
+ [fragment #f])]
+ [target (url->string relative)])
+ (if (string=? target "") "/" target)))
+
+(define (header-value headers name)
+ (for/or ([header (in-list headers)])
+ (let* ([text
+ (if (bytes? header)
+ (bytes->string/latin-1 header)
+ header)]
+ [match
+ (and (string? text)
+ (regexp-match
+ #px"^([^:]+):[ \t]*(.*?)[ \t]*$"
+ text))])
+ (and match
+ (string-ci=? (cadr match) name)
+ (caddr match)))))
+
+(define (protocol-info-parts protocol-info)
+ (and protocol-info
+ (regexp-match #px"^([^:]*):([^:]*):([^:]*):(.*)$"
+ protocol-info)))
+
+(define (protocol-info-additional-info protocol-info)
+ (let ([parts (protocol-info-parts protocol-info)])
+ (and parts (list-ref parts 4))))
+
+(define (replace-additional-info protocol-info additional-info)
+ (match (protocol-info-parts protocol-info)
+ [(list _ protocol network content-type _)
+ (string-join
+ (list protocol network content-type additional-info)
+ ":")]
+ [_ protocol-info]))
+
+(define (call-with-timeout seconds thunk)
+ (let ([custodian (make-custodian)]
+ [result-channel (make-channel)])
+ (parameterize ([current-custodian custodian])
+ (thread
+ (lambda ()
+ (with-handlers
+ ([exn:fail?
+ (lambda (exception)
+ (channel-put result-channel
+ (cons #f exception)))])
+ (channel-put result-channel
+ (cons #t (thunk)))))))
+ (let ([result (sync/timeout seconds result-channel)])
+ (custodian-shutdown-all custodian)
+ (cond
+ [(not result)
+ (error 'resolve-dlna-resource-protocol-info
+ "HTTP capability request timed out")]
+ [(car result) (cdr result)]
+ [else (raise (cdr result))]))))
+
+(define (request-content-features uri timeout)
+ (let* ([url-value (string->url uri)]
+ [scheme (or (url-scheme url-value) "http")]
+ [ssl? (string-ci=? scheme "https")]
+ [host (url-host url-value)]
+ [port (or (url-port url-value) (if ssl? 443 80))])
+ (unless (and host
+ (or (string-ci=? scheme "http")
+ (string-ci=? scheme "https")))
+ (raise-arguments-error
+ 'resolve-dlna-resource-protocol-info
+ "resource is not an HTTP URI"
+ "uri" uri))
+ (call-with-timeout
+ timeout
+ (lambda ()
+ (let-values ([(status headers in)
+ (http-sendrecv
+ host
+ (url-request-target url-value)
+ #:ssl? ssl?
+ #:port port
+ #:method #"HEAD"
+ #:headers
+ (list "getcontentFeatures.dlna.org: 1"
+ "transferMode.dlna.org: Streaming"
+ "Connection: close"))])
+ (void status)
+ (close-input-port in)
+ (header-value headers "contentFeatures.dlna.org"))))))
+
+(define (base-protocol-info protocol-info mime-type)
+ (cond
+ [(and (string? protocol-info)
+ (not (string=? (string-trim protocol-info) "")))
+ protocol-info]
+ [(and (string? mime-type)
+ (not (string=? (string-trim mime-type) "")))
+ (format "http-get:*:~a:*" mime-type)]
+ [else "http-get:*:application/octet-stream:*"]))
+
+(define (resolve-dlna-resource-protocol-info
+ uri
+ #:protocol-info [protocol-info #f]
+ #:mime-type [mime-type #f]
+ #:timeout [timeout 5.0])
+ (unless (and (string? uri)
+ (not (string=? (string-trim uri) "")))
+ (raise-argument-error
+ 'resolve-dlna-resource-protocol-info
+ "non-empty-string?"
+ uri))
+ (for ([value (in-list (list protocol-info mime-type))])
+ (unless (or (not value) (string? value))
+ (raise-argument-error
+ 'resolve-dlna-resource-protocol-info
+ "(or/c #f string?)"
+ value)))
+ (unless (and (rational? timeout) (positive? timeout))
+ (raise-argument-error
+ 'resolve-dlna-resource-protocol-info
+ "positive-real?"
+ timeout))
+ (let* ([base (base-protocol-info protocol-info mime-type)]
+ [additional-info (protocol-info-additional-info base)])
+ (cond
+ [(and additional-info
+ (not (string=? additional-info "*")))
+ base]
+ [else
+ (let* ([key (list uri base)]
+ [cached
+ (call-with-semaphore
+ capability-cache-lock
+ (lambda () (hash-ref capability-cache key #f)))])
+ (or cached
+ (with-handlers
+ ([exn:fail?
+ (lambda (exception)
+ (warn-upnp-resource
+ "Could not resolve DLNA capabilities for ~a: ~a"
+ uri
+ (exn-message exception))
+ base)])
+ (let ([content-features
+ (request-content-features uri timeout)])
+ (if (and content-features
+ (not (string=? content-features "")))
+ (let ([resolved
+ (replace-additional-info
+ base
+ content-features)])
+ (dbg-upnp-resource
+ "Resolved DLNA protocolInfo for ~a: ~a"
+ uri
+ resolved)
+ (call-with-semaphore
+ capability-cache-lock
+ (lambda ()
+ (hash-set! capability-cache key resolved)))
+ resolved)
+ base)))))])))
+
+(module+ test
+ (require rackunit)
+
+ (check-equal?
+ (replace-additional-info
+ "http-get:*:audio/flac:*"
+ "DLNA.ORG_OP=01;DLNA.ORG_CI=0")
+ "http-get:*:audio/flac:DLNA.ORG_OP=01;DLNA.ORG_CI=0"))
diff --git a/scribblings/media-renderer.scrbl b/scribblings/media-renderer.scrbl
index d16635f..c9d5d77 100644
--- a/scribblings/media-renderer.scrbl
+++ b/scribblings/media-renderer.scrbl
@@ -71,6 +71,27 @@ included in the UPnP device description.
@section{Playback}
+@defproc[(media-renderer-play-resource!
+ [renderer media-renderer?]
+ [uri string?]
+ [#:protocol-info protocol-info (or/c #f string?) #f]
+ [#:mime-type mime-type (or/c #f string?) #f]
+ [#:title title string? "Media"]
+ [#:artist artist (or/c #f string?) #f]
+ [#:album album (or/c #f string?) #f]
+ [#:genre genre (or/c #f string?) #f]
+ [#:year year (or/c #f exact-nonnegative-integer?) #f]
+ [#:track track (or/c #f exact-nonnegative-integer?) #f]
+ [#:duration duration (or/c #f number?) #f]
+ [#:size size (or/c #f exact-nonnegative-integer?) #f])
+ any]{
+
+Resolves missing DLNA HTTP capabilities, generates DIDL-Lite for the resource,
+and starts playback. A wildcard fourth field in @racket[protocol-info] is
+replaced with the server's @tt{contentFeatures.dlna.org} response when
+available. Successful capability responses are cached by URI.
+}
+
@defproc[(media-renderer-play-uri!
[renderer media-renderer?]
[uri string?]
@@ -117,6 +138,25 @@ that resource, call this function again to preload the following track. Use
metadata that describes @racket[uri], not the current resource.
}
+@defproc[(media-renderer-set-next-resource!
+ [renderer media-renderer?]
+ [uri string?]
+ [#:protocol-info protocol-info (or/c #f string?) #f]
+ [#:mime-type mime-type (or/c #f string?) #f]
+ [#:title title string? "Media"]
+ [#:artist artist (or/c #f string?) #f]
+ [#:album album (or/c #f string?) #f]
+ [#:genre genre (or/c #f string?) #f]
+ [#:year year (or/c #f exact-nonnegative-integer?) #f]
+ [#:track track (or/c #f exact-nonnegative-integer?) #f]
+ [#:duration duration (or/c #f number?) #f]
+ [#:size size (or/c #f exact-nonnegative-integer?) #f])
+ any]{
+
+Resolves and describes an external resource like
+@racket[media-renderer-play-resource!], then installs it as the next URI.
+}
+
@defproc[(media-renderer-pause! [renderer media-renderer?]) any]
@defproc[(media-renderer-stop! [renderer media-renderer?]) any]
@defproc[(media-renderer-seek!
diff --git a/scribblings/media-server.scrbl b/scribblings/media-server.scrbl
index db5f2ed..ef92c15 100644
--- a/scribblings/media-server.scrbl
+++ b/scribblings/media-server.scrbl
@@ -91,6 +91,8 @@ Equivalent to browsing the supplied container.
@defproc[(media-item-album [item media-item?]) (or/c #f string?)]
@defproc[(media-item-genres [item media-item?]) (listof string?)]
@defproc[(media-item-date [item media-item?]) (or/c #f string?)]
+@defproc[(media-item-original-track-number [item media-item?])
+ (or/c #f exact-integer?)]
@defproc[(media-item-album-art-uri [item media-item?])
(or/c #f string?)]
@defproc[(media-item-resources [item media-item?])
diff --git a/tests/media-file-server-test.rkt b/tests/media-file-server-test.rkt
index da917b6..746e512 100644
--- a/tests/media-file-server-test.rkt
+++ b/tests/media-file-server-test.rkt
@@ -49,8 +49,9 @@
#:listen-ip "127.0.0.1"))
(media-file-server-publish! server file "track.flac"))
(lambda ()
- (let ([head (http-request port "HEAD")]
- [range (http-request port "GET" #:range "bytes=2-5")])
+ (let* ([head (http-request port "HEAD")]
+ [range (http-request port "GET" #:range "bytes=2-5")]
+ [uri (format "http://127.0.0.1:~a/media/track.flac" port)])
(check-regexp-match #rx#"HTTP/1[.]1 200" head)
(check-regexp-match #rx#"(?i:Accept-Ranges): bytes" head)
(check-regexp-match
@@ -59,7 +60,12 @@
(check-equal? (response-body head) #"")
(check-regexp-match #rx#"HTTP/1[.]1 206" range)
(check-regexp-match #rx#"(?i:Content-Range): bytes 2-5/10" range)
- (check-equal? (response-body range) #"2345")))
+ (check-equal? (response-body range) #"2345")
+ (check-equal?
+ (resolve-dlna-resource-protocol-info
+ uri
+ #:protocol-info "http-get:*:audio/flac:*")
+ "http-get:*:audio/flac:DLNA.ORG_OP=01;DLNA.ORG_CI=0")))
(lambda ()
(when server
(media-file-server-stop! server))
diff --git a/tests/media-server-test.rkt b/tests/media-server-test.rkt
index 21d03e4..e922397 100644
--- a/tests/media-server-test.rkt
+++ b/tests/media-server-test.rkt
@@ -29,6 +29,7 @@
"String Quartet"
"Classical"
"2026-07-15"
+ "7"
"/cover/100.jpg"
"object.item.audioItem.musicTrack"
"