Files
rkt-web-player/private/dlna-playback.rkt
T
2026-09-01 09:31:49 +02:00

540 lines
22 KiB
Racket

#lang racket/base
(require racket-audio-dlna
racket/list
racket/path
racket/string
simple-log
"library.rkt")
(provide make-dlna-playback
dlna-playback-play-index!
dlna-playback-pause!
dlna-playback-resume!
dlna-playback-stop!
dlna-playback-seek-percentage!
dlna-playback-volume!
dlna-playback-repeat!
dlna-playback-close!)
(sl-def-log web-player-dlna)
;; This module deliberately contains only playlist orchestration. Transport,
;; HTTP publication, metadata, polling and seeking remain the responsibility
;; of racket-audio-dlna.
(struct dlna-playback
(player
tracks
update
error
[repeat #:mutable]
[current-index #:mutable]
[current-uri #:mutable]
[prepared-index #:mutable]
[playing-seen? #:mutable]
[progress-seen? #:mutable]
[failure-active? #:mutable]
[stop-requested? #:mutable]
[stopped-polls #:mutable]
[play-request-ms #:mutable]
[reachable? #:mutable]
[running? #:mutable]
[monitor #:mutable]
lock)
#:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define playback-start-timeout-ms 8000)
;;; Returns the current time used to measure renderer start delays.
(define (now-ms)
(current-inexact-milliseconds))
;;; Maps renderer-specific transport states to the web player's states.
(define (normalize-state state)
(cond
((eq? state 'transitioning) 'starting)
((member state '(initialized no-media)) 'stopped)
(else state)))
;;; Determines whether state or position confirms that playback has started.
;; Position reporting is optional and notably unreliable on some Denon
;; renderers. PLAYING, TRANSITIONING or PAUSED is itself confirmation that the
;; renderer accepted the transport. A positive position remains useful for
;; devices whose transport state lags behind their position response.
(define (renderer-confirms-playback? state position)
(cond
((member state '(playing starting paused)) #t)
((and (number? position) (> position 0)) #t)
(else #f)))
;;; Runs a playback operation while holding its synchronization lock.
(define (with-lock playback proc)
(call-with-semaphore (dlna-playback-lock playback) proc))
;;; Reads the current playlist through the callback supplied by the owner.
(define (current-tracks playback)
((dlna-playback-tracks playback)))
;;; Checks whether index identifies a track in the current playlist.
(define (valid-index? playback index)
(and (exact-nonnegative-integer? index)
(< index (length (current-tracks playback)))))
;;; Returns the track at index, or #f when the index is invalid.
(define (track-at playback index)
(if (valid-index? playback index)
(list-ref (current-tracks playback) index)
#f))
;;; Produces a complete path string for stable renderer file comparison.
(define (normalized-file file)
(with-handlers ((exn:fail? (λ (_) (format "~a" file))))
(path->string (path->complete-path file))))
;;; Compares two track files using the path rules of the current platform.
(define (same-file? first second)
(cond
((eq? first #f) #f)
((eq? second #f) #f)
(else
(let ((same-path? (if (eq? (system-type 'os) 'windows)
string-ci=?
string=?)))
(same-path? (normalized-file first)
(normalized-file second))))))
;;; Selects the following playlist index according to the repeat setting.
(define (next-index playback index)
(let ((count (length (current-tracks playback))))
(cond
((zero? count) #f)
((eq? (dlna-playback-repeat playback) 'one) index)
((< (+ index 1) count) (+ index 1))
((eq? (dlna-playback-repeat playback) 'all) 0)
(else #f))))
;;; Finds the playlist index represented by renderer metadata.
;;; A prepared index is checked first before searching the complete playlist.
(define (track-index-for-info playback info)
(let* ((info-track (dlna-info-track info))
(file (if (eq? info-track #f)
#f
(dlna-track-info-file info-track)))
(prepared (dlna-playback-prepared-index playback)))
(if (and (valid-index? playback prepared)
(same-file? file (track-file (track-at playback prepared))))
prepared
(let loop ((remaining (current-tracks playback))
(index 0))
(cond
((null? remaining) #f)
((same-file? file (track-file (car remaining))) index)
(else
(loop (cdr remaining) (add1 index))))))))
;;; Sends the current playback state and renderer information to the owner.
(define (notify! playback state info)
((dlna-playback-update playback)
state
(dlna-playback-current-index playback)
info))
;;; Records a playback failure and forwards its detail to the error callback.
(define (report-failure! playback detail)
(set-dlna-playback-playing-seen?! playback #f)
(set-dlna-playback-progress-seen?! playback #f)
(set-dlna-playback-failure-active?! playback #t)
(set-dlna-playback-play-request-ms! playback #f)
(set-dlna-playback-stopped-polls! playback 0)
((dlna-playback-error playback) detail))
;;; Prepares the next track on renderers that support gapless continuation.
(define (prepare-next! playback)
(let ((current (dlna-playback-current-index playback)))
(when (valid-index? playback current)
(let ((following (next-index playback current)))
(cond
((eq? following #f)
(set-dlna-playback-prepared-index! playback #f))
((not (equal? following (dlna-playback-prepared-index playback)))
(with-handlers
((exn:fail?
(λ (exception)
(set-dlna-playback-prepared-index! playback #f)
(warn-web-player-dlna
"Could not prepare next DLNA track: ~a"
(exn-message exception)))))
(dlna-player-set-next-file!
(dlna-playback-player playback)
(track-file (track-at playback following)))
(set-dlna-playback-prepared-index! playback following))))))))
;;; Starts one playlist item while the caller holds the playback lock.
(define (play-index/locked! playback index)
(let ((item (track-at playback index)))
(unless item
(raise-arguments-error
'dlna-playback-play-index!
"track index is outside the playlist"
"index" index))
(with-handlers
((exn:fail?
(λ (exception)
(report-failure! playback (exn-message exception))
(raise exception))))
(dlna-player-play! (dlna-playback-player playback) (track-file item))
(let ((info (dlna-player-info (dlna-playback-player playback))))
(set-dlna-playback-current-index! playback index)
(set-dlna-playback-current-uri! playback (dlna-info-uri info))
(set-dlna-playback-prepared-index! playback #f)
(set-dlna-playback-playing-seen?! playback #t)
(set-dlna-playback-progress-seen?! playback #f)
(set-dlna-playback-failure-active?! playback #f)
(set-dlna-playback-play-request-ms! playback (now-ms))
(set-dlna-playback-stop-requested?! playback #f)
(set-dlna-playback-stopped-polls! playback 0)
(notify! playback 'starting info)
(prepare-next! playback)))))
;;; Updates the current index when renderer metadata identifies another track.
(define (update-current-track! playback info)
(let ((index (track-index-for-info playback info)))
(when (valid-index? playback index)
(unless (equal? index (dlna-playback-current-index playback))
(set-dlna-playback-progress-seen?! playback #f)
(set-dlna-playback-play-request-ms! playback (now-ms)))
(set-dlna-playback-current-index! playback index)
(set-dlna-playback-prepared-index! playback #f)
(prepare-next! playback))))
;;; Advances to the next track or stops when the playlist has ended.
(define (advance! playback)
(let* ((current (dlna-playback-current-index playback))
(following (if (valid-index? playback current)
(next-index playback current)
#f)))
(if (eq? following #f)
(begin
(dlna-player-stop! (dlna-playback-player playback))
(notify! playback
'stopped
(dlna-player-info (dlna-playback-player playback))))
(play-index/locked! playback following))))
;;; Processes one successful renderer poll while the playback lock is held.
;;; It updates track identity, start confirmation and end-of-track handling.
(define (poll-reachable/locked! playback info)
(let ((state (normalize-state (dlna-info-state info)))
(uri (dlna-info-uri info))
(position (dlna-info-position info)))
(set-dlna-playback-reachable?! playback #t)
(when (and (string? uri)
(not (string=? uri ""))
(not (equal? uri (dlna-playback-current-uri playback))))
(set-dlna-playback-current-uri! playback uri)
(set-dlna-playback-stopped-polls! playback 0)
(update-current-track! playback info))
(when (renderer-confirms-playback? state position)
(set-dlna-playback-progress-seen?! playback #t))
(let* ((request-ms (dlna-playback-play-request-ms playback))
(elapsed-ms (if (eq? request-ms #f)
#f
(- (now-ms) request-ms)))
(failed-now?
(and (dlna-playback-playing-seen? playback)
(not (dlna-playback-progress-seen? playback))
elapsed-ms
(>= elapsed-ms playback-start-timeout-ms))))
;;; Handles a stopped renderer after start and progress checks complete.
(define (handle-stopped!)
(cond
((and (not (dlna-playback-progress-seen? playback))
elapsed-ms
(< elapsed-ms 5000))
(void))
((not (dlna-playback-progress-seen? playback))
(warn-web-player-dlna
"DLNA renderer stopped without confirming playback: position=~a uri=~a"
position (or uri ""))
(report-failure!
playback
'dlna-renderer-no-start-of-track-confirmation))
(else
(set-dlna-playback-stopped-polls!
playback
(+ 1 (dlna-playback-stopped-polls playback)))
;; Give SetNextAVTransportURI one poll to take over. Some renderers
;; need the explicit fallback on the next poll.
(when (or (eq? (dlna-playback-prepared-index playback) #f)
(> (dlna-playback-stopped-polls playback) 1))
(set-dlna-playback-playing-seen?! playback #f)
(set-dlna-playback-stopped-polls! playback 0)
(advance! playback)))))
(when failed-now?
(warn-web-player-dlna
"DLNA start was not confirmed: state=~a position=~a uri=~a"
state position (or uri ""))
(report-failure!
playback
'dlna-renderer-no-start-of-track-confirmation))
(unless (or failed-now? (dlna-playback-failure-active? playback))
(cond
((eq? state 'playing)
(set-dlna-playback-playing-seen?! playback #t)
(set-dlna-playback-stopped-polls! playback 0))
((and (eq? state 'stopped)
(dlna-playback-stop-requested? playback))
(set-dlna-playback-stop-requested?! playback #f)
(set-dlna-playback-stopped-polls! playback 0))
((and (eq? state 'stopped)
(dlna-playback-playing-seen? playback))
(handle-stopped!))))
(notify!
playback
(cond
((or failed-now? (dlna-playback-failure-active? playback))
'stopped)
((and (dlna-playback-playing-seen? playback)
(not (dlna-playback-progress-seen? playback)))
'starting)
(else state))
info))))
;;; Polls the renderer and reports a transition to an unreachable state once.
(define (poll/locked! playback)
(let ((info (dlna-player-info (dlna-playback-player playback))))
(if (dlna-info-reachable? info)
(poll-reachable/locked! playback info)
(when (dlna-playback-reachable? playback)
(set-dlna-playback-reachable?! playback #f)
((dlna-playback-error playback)
'dlna-renderer-unreachable)))))
;;; Polls the renderer until playback is closed, logging recoverable failures.
(define (monitor-loop playback poll-seconds)
(let loop ()
(when (dlna-playback-running? playback)
(sleep poll-seconds)
(when (dlna-playback-running? playback)
(with-handlers
((exn:fail?
(λ (exception)
(warn-web-player-dlna
"Could not update DLNA playback state: ~a"
(exn-message exception)))))
(with-lock playback (λ () (poll/locked! playback))))
(loop)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create playlist-aware playback for one network renderer.
; pre : Device is a media renderer, callbacks are procedures, and
; media-server is a running shared media-file-server.
; post : A DLNA player and its state-monitor thread are running.
; result : A playback adapter that publishes through the supplied server.
; internals: make-dlna-player creates the renderer interface; monitor-loop polls
; it periodically. poll/locked! reconciles URI, transport state and
; position with the playlist and reports updates, failures or track
; advancement. with-lock orders polls and commands using the
; dlna-playback-lock accessor generated for the struct's lock field.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-dlna-playback device
tracks
update
error
#:media-file-server media-server
#:poll-seconds [poll-seconds 1])
(let* ((raw (make-dlna-player device
#:media-file-server media-server))
(playback
(dlna-playback raw tracks update error 'off #f #f #f
#f #f #f #f 0 #f #t #t #f
(make-semaphore 1))))
(set-dlna-playback-monitor!
playback
(thread (λ () (monitor-loop playback poll-seconds))))
playback))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Start the track at index in the current playlist.
; pre : Playback is open and index identifies an existing track.
; post : The renderer starts the track and the next track is prepared.
; result : The result of the synchronized playback operation.
; internals: Playback state changes and callbacks run while holding the lock.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-play-index! playback index)
(with-lock playback (λ () (play-index/locked! playback index))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Pause the current renderer transport.
; pre : Playback is open and the renderer accepts pause requests.
; post : The renderer is paused and listeners receive the new state.
; result : The result of the synchronized playback operation.
; internals: The renderer is queried immediately after the pause request.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-pause! playback)
(with-lock
playback
(λ ()
(dlna-player-pause! (dlna-playback-player playback))
(notify! playback 'paused (dlna-player-info (dlna-playback-player playback))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resume the paused renderer transport.
; pre : Playback is open and the renderer accepts resume requests.
; post : The renderer is playing and listeners receive the new state.
; result : The result of the synchronized playback operation.
; internals: The renderer is queried immediately after the resume request.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-resume! playback)
(with-lock
playback
(λ ()
(dlna-player-resume! (dlna-playback-player playback))
(notify! playback 'playing (dlna-player-info (dlna-playback-player playback))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Stop the current renderer transport.
; pre : Playback is open.
; post : Pending start and failure state is cleared and listeners see stopped.
; result : The result of the synchronized playback operation.
; internals: stop-requested? distinguishes this stop from a finished track.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-stop! playback)
(with-lock
playback
(λ ()
(set-dlna-playback-stop-requested?! playback #t)
(set-dlna-playback-playing-seen?! playback #f)
(set-dlna-playback-progress-seen?! playback #f)
(set-dlna-playback-failure-active?! playback #f)
(set-dlna-playback-play-request-ms! playback #f)
(set-dlna-playback-stopped-polls! playback 0)
(dlna-player-stop! (dlna-playback-player playback))
(notify! playback 'stopped (dlna-player-info (dlna-playback-player playback))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Seek to a percentage of the current track.
; pre : Playback is open and percentage is accepted by the DLNA player.
; post : The renderer position and listener state reflect the requested seek.
; result : The result of the synchronized playback operation.
; internals: The synchronously refreshed DLNA cache is published immediately.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-seek-percentage! playback percentage)
(with-lock
playback
(λ ()
(dlna-player-seek-percentage! (dlna-playback-player playback) percentage)
;; racket-audio-dlna updates its cache synchronously after Seek. Publish
;; that value immediately so the web slider does not jump back.
(let ((info (dlna-player-info (dlna-playback-player playback))))
(notify! playback
(normalize-state (dlna-info-state info))
info)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Set the renderer volume to a percentage.
; pre : Playback is open and percentage is accepted by the DLNA player.
; post : The renderer volume and listener state reflect the requested value.
; result : The result of the synchronized playback operation.
; internals: The renderer is queried immediately after changing the volume.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-volume! playback percentage)
(with-lock
playback
(λ ()
(dlna-player-volume! (dlna-playback-player playback) percentage)
(let ((info (dlna-player-info (dlna-playback-player playback))))
(notify! playback
(normalize-state (dlna-info-state info))
info)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Change playlist repeat behavior.
; pre : Playback is open and repeat is 'off, 'one or 'all.
; post : The next prepared track reflects the new repeat behavior.
; result : The result of the synchronized playback operation.
; internals: Any previously prepared index is discarded before recalculation.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-repeat! playback repeat)
(with-lock
playback
(λ ()
(set-dlna-playback-repeat! playback repeat)
(set-dlna-playback-prepared-index! playback #f)
(prepare-next! playback))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Close playback and release its renderer resources.
; pre : Playback was created by make-dlna-playback.
; post : The monitor has stopped and the underlying DLNA player is closed.
; result : Void.
; internals: The running flag prevents repeated closure of the same player.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-close! playback)
(when (dlna-playback-running? playback)
(set-dlna-playback-running?! playback #f)
(let ((monitor (dlna-playback-monitor playback)))
(when (and monitor (not (thread-dead? monitor)))
(kill-thread monitor))
(set-dlna-playback-monitor! playback #f)
(with-lock
playback
(λ ()
(dlna-player-close! (dlna-playback-player playback)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module dlna-playback.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require rackunit)
(define first
(track (build-path "music" "01.flac")
"First" "Artist" "Album" 60 "audio/flac"))
(define second
(track (build-path "music" "02.flac")
"Second" "Artist" "Album" 60 "audio/flac"))
(define playback
(dlna-playback #f (λ () (list first second)) void void
'off 0 #f #f #f #f #f #f 0 #f #t #f #f
(make-semaphore 1)))
(check-equal? (next-index playback 0) 1)
(check-false (next-index playback 1))
(set-dlna-playback-repeat! playback 'all)
(check-equal? (next-index playback 1) 0)
(set-dlna-playback-repeat! playback 'one)
(check-equal? (next-index playback 1) 1)
(let ((second-info
(dlna-info
'playing
(dlna-track-info (track-file second) "Second" "Artist" "Album"
#f #f #f 60 #f #f #f)
"http://renderer.test/02.flac"
#f #f 1 60 25 #f #t)))
(set-dlna-playback-prepared-index! playback 1)
(check-equal? (track-index-for-info playback second-info) 1)
(set-dlna-playback-prepared-index! playback #f)
(check-equal? (track-index-for-info playback second-info) 1)
(check-false
(track-index-for-info
playback
(struct-copy dlna-info second-info (track #f)))))
(check-eq? (normalize-state 'transitioning) 'starting)
(check-eq? (normalize-state 'no-media) 'stopped)
(check-true (renderer-confirms-playback? 'playing #f))
(check-true (renderer-confirms-playback? 'starting 0))
(check-true (renderer-confirms-playback? 'paused #f))
(check-true (renderer-confirms-playback? 'unknown 1))
(check-false (renderer-confirms-playback? 'stopped 0)))