Better renderer and server support and higher level functions. Seek solutions.

.gitignore

@@ -19,3 +19,4 @@ compiled/
 /scribblings/*.css
 /scribblings/*.js
 /scribblings/*.html
+/doc

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

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

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)

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

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

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!

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?])

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")]
+    (let* ([head (http-request port "HEAD")]
-          [range (http-request port "GET" #:range "bytes=2-5")])
+           [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))

tests/media-server-test.rkt

@@ -29,6 +29,7 @@
    "<upnp:album>String Quartet</upnp:album>"
    "<upnp:genre>Classical</upnp:genre>"
    "<dc:date>2026-07-15</dc:date>"
+   "<upnp:originalTrackNumber>7</upnp:originalTrackNumber>"
    "<upnp:albumArtURI>/cover/100.jpg</upnp:albumArtURI>"
    "<upnp:class>object.item.audioItem.musicTrack</upnp:class>"
    "<res protocolInfo=\"http-get:*:audio/flac:DLNA.ORG_PN=FLAC\" "
@@ -120,6 +121,7 @@
 (check-equal? (media-item-album track) "String Quartet")
 (check-equal? (media-item-genres track) '("Classical"))
 (check-equal? (media-item-date track) "2026-07-15")
+(check-equal? (media-item-original-track-number track) 7)
 (check-equal? (media-item-album-art-uri track)
               (format "http://127.0.0.1:~a/cover/100.jpg" port))