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