426 lines
15 KiB
Racket
426 lines
15 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)
|
|
|
|
(define playback-start-timeout-ms 8000)
|
|
|
|
(define (now-ms)
|
|
(current-inexact-milliseconds))
|
|
|
|
(define (normalize-state state)
|
|
(cond
|
|
((eq? state 'transitioning) 'starting)
|
|
((member state '(initialized no-media)) 'stopped)
|
|
(else state)))
|
|
|
|
;; 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)
|
|
(or (and (member state '(playing starting paused)) #t)
|
|
(and (number? position) (> position 0))))
|
|
|
|
(define (with-lock playback proc)
|
|
(call-with-semaphore (dlna-playback-lock playback) proc))
|
|
|
|
(define (current-tracks playback)
|
|
((dlna-playback-tracks playback)))
|
|
|
|
(define (valid-index? playback index)
|
|
(and (exact-nonnegative-integer? index)
|
|
(< index (length (current-tracks playback)))))
|
|
|
|
(define (track-at playback index)
|
|
(and (valid-index? playback index)
|
|
(list-ref (current-tracks playback) index)))
|
|
|
|
(define (normalized-file file)
|
|
(with-handlers ((exn:fail? (lambda (_) (format "~a" file))))
|
|
(path->string (path->complete-path file))))
|
|
|
|
(define (same-file? first second)
|
|
(and first
|
|
second
|
|
((if (eq? (system-type 'os) 'windows)
|
|
string-ci=?
|
|
string=?)
|
|
(normalized-file first)
|
|
(normalized-file second))))
|
|
|
|
(define (next-index playback index)
|
|
(define 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)))
|
|
|
|
(define (track-index-for-info playback info)
|
|
(define info-track (dlna-info-track info))
|
|
(define file (and info-track (dlna-track-info-file info-track)))
|
|
(define prepared (dlna-playback-prepared-index playback))
|
|
(cond
|
|
((and (valid-index? playback prepared)
|
|
(same-file? file (track-file (track-at playback prepared))))
|
|
prepared)
|
|
(else
|
|
(for/first ((item (in-list (current-tracks playback)))
|
|
(index (in-naturals))
|
|
#:when (same-file? file (track-file item)))
|
|
index))))
|
|
|
|
(define (notify! playback state info)
|
|
((dlna-playback-update playback)
|
|
state
|
|
(dlna-playback-current-index playback)
|
|
info))
|
|
|
|
(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))
|
|
|
|
(define (prepare-next! playback)
|
|
(define current (dlna-playback-current-index playback))
|
|
(when (valid-index? playback current)
|
|
(define following (next-index playback current))
|
|
(cond
|
|
((not following)
|
|
(set-dlna-playback-prepared-index! playback #f))
|
|
((not (equal? following (dlna-playback-prepared-index playback)))
|
|
(with-handlers
|
|
((exn:fail?
|
|
(lambda (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))))))
|
|
|
|
(define (play-index/locked! playback index)
|
|
(define 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?
|
|
(lambda (exception)
|
|
(report-failure! playback (exn-message exception))
|
|
(raise exception))))
|
|
(dlna-player-play! (dlna-playback-player playback) (track-file item))
|
|
(define 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)))
|
|
|
|
(define (update-current-track! playback info)
|
|
(define 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)))
|
|
|
|
(define (advance! playback)
|
|
(define current (dlna-playback-current-index playback))
|
|
(define following (and (valid-index? playback current)
|
|
(next-index playback current)))
|
|
(if following
|
|
(play-index/locked! playback following)
|
|
(begin
|
|
(dlna-player-stop! (dlna-playback-player playback))
|
|
(notify! playback
|
|
'stopped
|
|
(dlna-player-info (dlna-playback-player playback))))))
|
|
|
|
(define (poll/locked! playback)
|
|
(define info (dlna-player-info (dlna-playback-player playback)))
|
|
(cond
|
|
((not (dlna-info-reachable? info))
|
|
(when (dlna-playback-reachable? playback)
|
|
(set-dlna-playback-reachable?! playback #f)
|
|
((dlna-playback-error playback) "De DLNA-renderer is niet bereikbaar")))
|
|
(else
|
|
(set-dlna-playback-reachable?! playback #t)
|
|
(define state (normalize-state (dlna-info-state info)))
|
|
(define uri (dlna-info-uri info))
|
|
(define position (dlna-info-position info))
|
|
(define failed-now? #f)
|
|
|
|
(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))
|
|
|
|
(when (and (dlna-playback-playing-seen? playback)
|
|
(not (dlna-playback-progress-seen? playback))
|
|
(dlna-playback-play-request-ms playback)
|
|
(>= (- (now-ms)
|
|
(dlna-playback-play-request-ms playback))
|
|
playback-start-timeout-ms))
|
|
(set! failed-now? #t)
|
|
(warn-web-player-dlna
|
|
"DLNA start was not confirmed: state=~a position=~a uri=~a"
|
|
state position (or uri ""))
|
|
(report-failure!
|
|
playback
|
|
"De DLNA-renderer bevestigde de start van de track niet"))
|
|
|
|
(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))
|
|
(cond
|
|
((and (not (dlna-playback-progress-seen? playback))
|
|
(dlna-playback-play-request-ms playback)
|
|
(< (- (now-ms)
|
|
(dlna-playback-play-request-ms playback))
|
|
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
|
|
"De DLNA-renderer bevestigde de start van de track niet"))
|
|
(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 following poll.
|
|
(when (or (not (dlna-playback-prepared-index playback))
|
|
(> (dlna-playback-stopped-polls playback) 1))
|
|
(set-dlna-playback-playing-seen?! playback #f)
|
|
(set-dlna-playback-stopped-polls! playback 0)
|
|
(advance! playback)))))))
|
|
|
|
(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))))
|
|
|
|
(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?
|
|
(lambda (exception)
|
|
(warn-web-player-dlna
|
|
"Could not update DLNA playback state: ~a"
|
|
(exn-message exception)))))
|
|
(with-lock playback (lambda () (poll/locked! playback))))
|
|
(loop)))))
|
|
|
|
(define (make-dlna-playback device
|
|
tracks
|
|
update
|
|
error
|
|
#:port [port 8734]
|
|
#:poll-seconds [poll-seconds 1])
|
|
(define raw
|
|
(make-dlna-player device
|
|
#:port port
|
|
#:path "/rkt-web-player/"))
|
|
(define 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 (lambda () (monitor-loop playback poll-seconds))))
|
|
playback)
|
|
|
|
(define (dlna-playback-play-index! playback index)
|
|
(with-lock playback (lambda () (play-index/locked! playback index))))
|
|
|
|
(define (dlna-playback-pause! playback)
|
|
(with-lock
|
|
playback
|
|
(lambda ()
|
|
(dlna-player-pause! (dlna-playback-player playback))
|
|
(notify! playback 'paused (dlna-player-info (dlna-playback-player playback))))))
|
|
|
|
(define (dlna-playback-resume! playback)
|
|
(with-lock
|
|
playback
|
|
(lambda ()
|
|
(dlna-player-resume! (dlna-playback-player playback))
|
|
(notify! playback 'playing (dlna-player-info (dlna-playback-player playback))))))
|
|
|
|
(define (dlna-playback-stop! playback)
|
|
(with-lock
|
|
playback
|
|
(lambda ()
|
|
(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))))))
|
|
|
|
(define (dlna-playback-seek-percentage! playback percentage)
|
|
(with-lock
|
|
playback
|
|
(lambda ()
|
|
(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.
|
|
(define info (dlna-player-info (dlna-playback-player playback)))
|
|
(notify! playback
|
|
(normalize-state (dlna-info-state info))
|
|
info))))
|
|
|
|
(define (dlna-playback-volume! playback percentage)
|
|
(with-lock
|
|
playback
|
|
(lambda ()
|
|
(dlna-player-volume! (dlna-playback-player playback) percentage)
|
|
(define info (dlna-player-info (dlna-playback-player playback)))
|
|
(notify! playback
|
|
(normalize-state (dlna-info-state info))
|
|
info))))
|
|
|
|
(define (dlna-playback-repeat! playback repeat)
|
|
(with-lock
|
|
playback
|
|
(lambda ()
|
|
(set-dlna-playback-repeat! playback repeat)
|
|
(set-dlna-playback-prepared-index! playback #f)
|
|
(prepare-next! playback))))
|
|
|
|
(define (dlna-playback-close! playback)
|
|
(when (dlna-playback-running? playback)
|
|
(set-dlna-playback-running?! playback #f)
|
|
(define monitor (dlna-playback-monitor playback))
|
|
(when (and monitor (not (thread-dead? monitor)))
|
|
(kill-thread monitor))
|
|
(set-dlna-playback-monitor! playback #f)
|
|
(with-lock
|
|
playback
|
|
(lambda ()
|
|
(dlna-player-close! (dlna-playback-player playback))))))
|
|
|
|
(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 (lambda () (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)
|
|
|
|
(set-dlna-playback-prepared-index! playback 1)
|
|
(check-equal?
|
|
(track-index-for-info
|
|
playback
|
|
(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))
|
|
1)
|
|
(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)))
|