hans/racket-upnp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-08 14:27:29 +02:00
parent 91c6755bb1
commit 3fbcdb09d5
10 changed files with 324 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+1
View File
@@ -19,3 +19,4 @@ compiled/
/scribblings/*.css
/scribblings/*.js
/scribblings/*.html
/doc
main.rkt
+2
View File
@@ -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
+60
View File
@@ -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
+5 -1
View File
@@ -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
+3 -1
View File
@@ -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
+200
View File
@@ -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
+40
View File
@@ -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
+2
View File
@@ -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
+9 -3
View File
@@ -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))
tests/media-server-test.rkt
+2
View File
@@ -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))