2335 lines
91 KiB
Racket
2335 lines
91 KiB
Racket
#lang racket/base
|
|
|
|
(require racket-audio
|
|
racket-audio-dlna
|
|
file/sha1
|
|
racket/list
|
|
racket/path
|
|
racket/random
|
|
racket/string
|
|
racket-sonos
|
|
racket-upnp
|
|
simple-log
|
|
uuid/random
|
|
"dlna-playback.rkt"
|
|
"library.rkt"
|
|
"playlists.rkt")
|
|
|
|
(provide player?
|
|
make-player
|
|
player-state->jsexpr
|
|
player-command!
|
|
player-discover!
|
|
player-agent-register!
|
|
player-agent-poll!
|
|
player-agent-media
|
|
player-track-artwork
|
|
player-user-language
|
|
player-user-language!
|
|
exn:fail:agent-denied?
|
|
player-close!)
|
|
|
|
(sl-def-log web-player)
|
|
|
|
(struct renderer
|
|
(id [name #:mutable] kind device)
|
|
#:transparent)
|
|
|
|
(struct playback-agent
|
|
(app-id
|
|
[name #:mutable]
|
|
[last-seen #:mutable]
|
|
[reported-state #:mutable]
|
|
[commands #:mutable]
|
|
[next-command-id #:mutable]
|
|
media
|
|
[ended-counter #:mutable])
|
|
#:transparent)
|
|
|
|
(struct exn:fail:agent-denied exn:fail ()
|
|
#:transparent)
|
|
|
|
(struct playlist-tab
|
|
(id [name #:mutable] [tracks #:mutable] [snapshot #:auto #:mutable])
|
|
#:auto-value #f
|
|
#:transparent)
|
|
|
|
(struct playlist-context
|
|
([tabs #:mutable] [current-index #:mutable] [saved #:auto #:mutable])
|
|
#:auto-value '()
|
|
#:transparent)
|
|
|
|
(struct playback-session
|
|
(username
|
|
[tracks #:mutable]
|
|
[selected-id #:mutable]
|
|
[backend #:mutable]
|
|
[backend-kind #:mutable]
|
|
[current-index #:mutable]
|
|
[state #:mutable]
|
|
[position #:mutable]
|
|
[duration #:mutable]
|
|
[rate #:mutable]
|
|
[channels #:mutable]
|
|
[bits #:mutable]
|
|
[decoder #:mutable]
|
|
[volume #:mutable]
|
|
[repeat #:mutable]
|
|
[error #:mutable]
|
|
local-music-indexes)
|
|
#:transparent)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Hold the shared libraries, playback sessions, outputs and UI state.
|
|
; pre : make-player supplies all fields and owns construction of the value.
|
|
; post : Creating or recognizing a player does not start an HTTP server.
|
|
; result : player? recognizes values accepted by the internal server API.
|
|
; internals: make-player initializes the state and command locks, playlist
|
|
; contexts and playback sessions. player-command! mutates that
|
|
; state, player-state->jsexpr reads it, and player-close! releases
|
|
; the owned playback and persistence resources.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(struct player
|
|
(libraries
|
|
allowed-agent-ids
|
|
[agents #:mutable]
|
|
[current-library-id #:mutable]
|
|
[browser-path #:mutable]
|
|
[browser-entries #:mutable]
|
|
[tracks #:mutable]
|
|
[tabs #:mutable]
|
|
[current-tab-index #:mutable]
|
|
[renderers #:mutable]
|
|
[error #:mutable]
|
|
[discovering? #:mutable]
|
|
[closed? #:mutable]
|
|
state-lock
|
|
command-lock
|
|
playlist-store
|
|
playlist-contexts
|
|
[active-playlist-user #:mutable]
|
|
dlna-port
|
|
playback-sessions
|
|
renderer-owners
|
|
[media-file-server #:mutable])
|
|
#:transparent)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Internal state / functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (with-state-lock value proc)
|
|
(call-with-semaphore (player-state-lock value) proc))
|
|
|
|
(define (renderer-by-id value id)
|
|
(and (string? id)
|
|
(findf (λ (item)
|
|
(string=? (renderer-id item) id))
|
|
(player-renderers value))))
|
|
|
|
(define (agent-renderer-id app-id)
|
|
(string-append "agent:" app-id))
|
|
|
|
(define (agent-by-id value app-id)
|
|
(findf (λ (agent)
|
|
(string=? (playback-agent-app-id agent) app-id))
|
|
(player-agents value)))
|
|
|
|
(define (agent-renderer value agent)
|
|
(renderer-by-id value
|
|
(agent-renderer-id
|
|
(playback-agent-app-id agent))))
|
|
|
|
(define (valid-agent-id? value)
|
|
(and (string? value)
|
|
(regexp-match? #px"^[0-9a-fA-F]{64}$" value)))
|
|
|
|
(define (normal-agent-id value)
|
|
(and (valid-agent-id? value)
|
|
(string-downcase value)))
|
|
|
|
(define (authorized-agent-id? value app-id)
|
|
(and (normal-agent-id app-id)
|
|
(member (normal-agent-id app-id)
|
|
(player-allowed-agent-ids value))
|
|
#t))
|
|
|
|
(define (require-authorized-agent! value app-id)
|
|
(unless (authorized-agent-id? value app-id)
|
|
(raise
|
|
(exn:fail:agent-denied
|
|
(format
|
|
"Playback agent ~a is niet toegestaan; voeg het applicatie-ID eerst toe aan [playback-agents] in de server-INI"
|
|
(or app-id "(ontbreekt)"))
|
|
(current-continuation-marks)))))
|
|
|
|
(define (fresh-media-token)
|
|
(bytes->hex-string (crypto-random-bytes 32)))
|
|
|
|
(define (track-cache-key item)
|
|
(sha1
|
|
(open-input-string
|
|
(path->string (track-file item)))))
|
|
|
|
(define (agent-track-data item index token)
|
|
(hasheq 'playlistIndex index
|
|
'trackNumber (+ index 1)
|
|
'cacheKey (track-cache-key item)
|
|
'mediaToken token
|
|
'filename
|
|
(path->string
|
|
(or (file-name-from-path (track-file item))
|
|
(track-file item)))
|
|
'title (track-title item)
|
|
'artist (track-artist item)
|
|
'album (track-album item)
|
|
'duration (or (track-duration item) 'null)))
|
|
|
|
(define (enqueue-agent-command! value agent action [data (hasheq)])
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(let* ((id (playback-agent-next-command-id agent))
|
|
(command (hasheq 'id id
|
|
'action action
|
|
'data data)))
|
|
(set-playback-agent-next-command-id! agent (+ id 1))
|
|
(set-playback-agent-commands!
|
|
agent
|
|
(append (playback-agent-commands agent)
|
|
(list command)))
|
|
command))))
|
|
|
|
(define agent-heartbeat-timeout-seconds 10)
|
|
|
|
(define (prune-stale-agents! value)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(let* ((cutoff (- (current-seconds)
|
|
agent-heartbeat-timeout-seconds))
|
|
(stale
|
|
(filter (λ (agent)
|
|
(< (playback-agent-last-seen agent) cutoff))
|
|
(player-agents value)))
|
|
(stale-ids
|
|
(map (λ (agent)
|
|
(agent-renderer-id
|
|
(playback-agent-app-id agent)))
|
|
stale)))
|
|
(unless (null? stale)
|
|
(set-player-agents!
|
|
value
|
|
(filter (λ (agent)
|
|
(not (member (agent-renderer-id
|
|
(playback-agent-app-id agent))
|
|
stale-ids)))
|
|
(player-agents value)))
|
|
(set-player-renderers!
|
|
value
|
|
(filter (λ (item)
|
|
(not (member (renderer-id item) stale-ids)))
|
|
(player-renderers value)))
|
|
(for ((session (in-hash-values (player-playback-sessions value))))
|
|
(when (member (playback-session-selected-id session) stale-ids)
|
|
(hash-remove! (player-renderer-owners value)
|
|
(playback-session-selected-id session))
|
|
(set-playback-session-selected-id!
|
|
session
|
|
(and (pair? (player-renderers value))
|
|
(renderer-id (car (player-renderers value)))))
|
|
(set-playback-session-backend! session #f)
|
|
(set-playback-session-backend-kind! session #f)
|
|
(set-playback-session-state! session 'stopped)
|
|
(set-playback-session-position! session 0)
|
|
(set-playback-session-duration! session #f)
|
|
(set-playback-session-error!
|
|
session
|
|
"De playback agent is niet meer verbonden")
|
|
(reset-audio-info! session))))))))
|
|
|
|
(define (library-by-id value id)
|
|
(findf (λ (library)
|
|
(string=? (music-library-id library) id))
|
|
(player-libraries value)))
|
|
|
|
(define (current-library value)
|
|
(and (player-current-library-id value)
|
|
(library-by-id value
|
|
(player-current-library-id value))))
|
|
|
|
(define (current-tab value)
|
|
(list-ref (player-tabs value)
|
|
(player-current-tab-index value)))
|
|
|
|
;;; Invalidate the browser snapshot only when the immutable track list changes.
|
|
(define (save-current-tab! value)
|
|
(let ((tab (current-tab value))
|
|
(tracks (player-tracks value)))
|
|
(unless (eq? tracks (playlist-tab-tracks tab))
|
|
(set-playlist-tab-tracks! tab tracks)
|
|
(set-playlist-tab-snapshot! tab #f))))
|
|
|
|
(define (normal-playlist-username username)
|
|
(let ((value (and (string? username)
|
|
(string-downcase (string-trim username)))))
|
|
(if (and value (not (string=? value ""))) value "anonymous")))
|
|
|
|
;;; Restore open tabs and the library using the same object for a shared UUID.
|
|
;;; Old stores have no saved index, so their tabs remain open and unsaved.
|
|
(define (restore-playlist-context store username libraries)
|
|
(let* ((restore (λ (tab) (playlist-tab (persisted-tab-id tab)
|
|
(persisted-tab-name tab)
|
|
(persisted-tab-tracks tab))))
|
|
(opened (map restore (load-user-playlists store username libraries)))
|
|
(tabs (if (pair? opened) opened
|
|
(list (playlist-tab (uuid-string) "Default" '()))))
|
|
(context (playlist-context tabs 0)))
|
|
(set-playlist-context-saved!
|
|
context
|
|
(map (λ (stored)
|
|
(or (findf (λ (tab) (string=? (playlist-tab-id tab) (persisted-tab-id stored)))
|
|
tabs)
|
|
(restore stored)))
|
|
(load-user-playlists store username libraries #:saved? #t)))
|
|
context))
|
|
|
|
(define (playlist-context-for! value username)
|
|
(define normalized (normal-playlist-username username))
|
|
(hash-ref!
|
|
(player-playlist-contexts value)
|
|
normalized
|
|
(λ () (restore-playlist-context (player-playlist-store value)
|
|
normalized (player-libraries value)))))
|
|
|
|
(define (context-tracks context)
|
|
(playlist-tab-tracks
|
|
(list-ref (playlist-context-tabs context)
|
|
(playlist-context-current-index context))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Resolve or lazily create one user's independent playback pipeline.
|
|
; pre : Value is a player and username can be normalized to a playlist user.
|
|
; post : A missing session is initialized from that user's selected playlist.
|
|
; result : The stable playback-session belonging to the normalized username.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (playback-session-for! value username)
|
|
(define normalized (normal-playlist-username username))
|
|
(hash-ref!
|
|
(player-playback-sessions value)
|
|
normalized
|
|
(λ ()
|
|
(define context (playlist-context-for! value normalized))
|
|
(playback-session
|
|
normalized
|
|
(context-tracks context)
|
|
(and (pair? (player-renderers value))
|
|
(renderer-id (car (player-renderers value))))
|
|
#f
|
|
#f
|
|
#f
|
|
'stopped
|
|
0
|
|
#f
|
|
#f
|
|
#f
|
|
#f
|
|
#f
|
|
50
|
|
'off
|
|
#f
|
|
(make-hash)))))
|
|
|
|
(define (activate-playlist-user! value username session)
|
|
(define normalized (normal-playlist-username username))
|
|
(unless (string=? normalized (player-active-playlist-user value))
|
|
(define context (playlist-context-for! value normalized))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-player-tabs! value (playlist-context-tabs context))
|
|
(set-player-current-tab-index!
|
|
value
|
|
(playlist-context-current-index context))
|
|
(set-player-tracks!
|
|
value
|
|
(playlist-tab-tracks
|
|
(list-ref (playlist-context-tabs context)
|
|
(playlist-context-current-index context))))
|
|
(set-player-active-playlist-user! value normalized))))
|
|
(set-playback-session-tracks! session (player-tracks value)))
|
|
|
|
(define (persist-playlists! value)
|
|
(define username (player-active-playlist-user value))
|
|
(define context (playlist-context-for! value username))
|
|
(set-playlist-context-tabs! context (player-tabs value))
|
|
(set-playlist-context-current-index!
|
|
context
|
|
(player-current-tab-index value))
|
|
(save-user-playlists!
|
|
(player-playlist-store value)
|
|
username
|
|
(for/list ((tab (in-list (player-tabs value))))
|
|
(persisted-tab (playlist-tab-id tab)
|
|
(playlist-tab-name tab)
|
|
(playlist-tab-tracks tab)))
|
|
#:saved
|
|
(map (λ (tab) (persisted-tab (playlist-tab-id tab)
|
|
(playlist-tab-name tab)
|
|
(playlist-tab-tracks tab)))
|
|
(playlist-context-saved context))))
|
|
|
|
(define (normalize-state state)
|
|
(cond
|
|
((eq? state 'playing) 'playing)
|
|
((eq? state 'paused) 'paused)
|
|
((eq? state 'transitioning) 'starting)
|
|
((eq? state 'initialized) 'stopped)
|
|
((eq? state 'no-media) 'stopped)
|
|
(else state)))
|
|
|
|
(define (set-error! value message)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-player-error! value message))))
|
|
|
|
(define (set-session-error! value session message)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-playback-session-error! session message))))
|
|
|
|
;;; Converts an internal error value to a JSON-compatible message or key.
|
|
(define (error->jsexpr error)
|
|
(cond
|
|
((eq? error #f) 'null)
|
|
((symbol? error) (symbol->string error))
|
|
(else error)))
|
|
|
|
(define (clear-session-error! value session)
|
|
(set-session-error! value session #f))
|
|
|
|
(define (reset-audio-info! session)
|
|
(set-playback-session-rate! session #f)
|
|
(set-playback-session-channels! session #f)
|
|
(set-playback-session-bits! session #f)
|
|
(set-playback-session-decoder! session #f))
|
|
|
|
(define (local-state-callback value session handle state full-state)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(when (eq? handle (playback-session-backend session))
|
|
(let* ((music-id (hash-ref full-state 'at-music-id #f))
|
|
(audible-index
|
|
(and (number? music-id)
|
|
(hash-ref (playback-session-local-music-indexes session)
|
|
music-id
|
|
#f))))
|
|
(when (exact-nonnegative-integer? audible-index)
|
|
(set-playback-session-current-index! session audible-index)))
|
|
(set-playback-session-state! session (normalize-state state))
|
|
(set-playback-session-position!
|
|
session
|
|
(or (hash-ref full-state 'at-second #f) 0))
|
|
(set-playback-session-duration!
|
|
session
|
|
(hash-ref full-state 'duration #f))
|
|
(set-playback-session-rate!
|
|
session
|
|
(hash-ref full-state 'rate #f))
|
|
(set-playback-session-channels!
|
|
session
|
|
(hash-ref full-state 'channels #f))
|
|
(set-playback-session-bits!
|
|
session
|
|
(hash-ref full-state 'bits #f))
|
|
(set-playback-session-decoder!
|
|
session
|
|
(hash-ref full-state 'decoder #f))))))
|
|
|
|
(define (local-end-callback value session handle)
|
|
(when (eq? handle (playback-session-backend session))
|
|
(with-handlers
|
|
((exn:fail?
|
|
(λ (exception)
|
|
(set-session-error! value session (exn-message exception)))))
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(let ((index (next-index session 1)))
|
|
;; Queue immediately at decoder EOF, but keep the old track selected
|
|
;; until libao reports the new music id as actually audible.
|
|
(when index
|
|
(play-index! value session index #t))))))))
|
|
|
|
(define (make-local-backend value session)
|
|
(let ((backend
|
|
(make-audio-player
|
|
(λ (handle state full-state)
|
|
(local-state-callback value session handle state full-state))
|
|
(λ (handle)
|
|
(local-end-callback value session handle)))))
|
|
(audio-ao-buf-ms! backend 500)
|
|
(audio-buf-seconds! backend 4 10)
|
|
(let ((logical-volume
|
|
(/ (playback-session-volume session) 100.0)))
|
|
(audio-volume!
|
|
backend
|
|
(* 100.0 logical-volume logical-volume)))
|
|
backend))
|
|
|
|
(define (network-state-callback value session state index info)
|
|
(define track-info (dlna-info-track info))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(when (valid-track-index? session index)
|
|
(set-playback-session-current-index! session index))
|
|
(set-playback-session-state! session state)
|
|
(set-playback-session-position!
|
|
session
|
|
(or (dlna-info-position info) 0))
|
|
(set-playback-session-duration! session (dlna-info-duration info))
|
|
(set-playback-session-rate!
|
|
session
|
|
(and track-info (dlna-track-info-sample-rate track-info)))
|
|
(set-playback-session-channels!
|
|
session
|
|
(and track-info (dlna-track-info-channels track-info)))
|
|
(set-playback-session-bits! session #f)
|
|
(set-playback-session-decoder! session 'dlna)
|
|
(when (number? (dlna-info-volume info))
|
|
(set-playback-session-volume! session (dlna-info-volume info))))))
|
|
|
|
(define (ensure-media-file-server! value)
|
|
(or (player-media-file-server value)
|
|
(let* ((address (upnp-default-ipv4-address))
|
|
(server
|
|
(start-media-file-server
|
|
(format "http://~a:~a/rkt-web-player/"
|
|
address
|
|
(player-dlna-port value))
|
|
#:listen-ip address)))
|
|
(set-player-media-file-server! value server)
|
|
server)))
|
|
|
|
(define (make-network-backend value session device)
|
|
(define backend
|
|
(make-dlna-playback
|
|
device
|
|
(λ () (playback-session-tracks session))
|
|
(λ (state index info)
|
|
(network-state-callback value session state index info))
|
|
(λ (message) (set-session-error! value session message))
|
|
#:media-file-server (ensure-media-file-server! value)))
|
|
(dlna-playback-repeat! backend (playback-session-repeat session))
|
|
backend)
|
|
|
|
(define (claim-renderer! value session)
|
|
(define id (playback-session-selected-id session))
|
|
(define owner (and id (hash-ref (player-renderer-owners value) id #f)))
|
|
(when (and owner (not (eq? owner session)))
|
|
(close-backend! value owner)
|
|
(set-session-error!
|
|
value
|
|
owner
|
|
"Het afspeelpunt is door een andere gebruiker overgenomen"))
|
|
(when id
|
|
(hash-set! (player-renderer-owners value) id session)))
|
|
|
|
(define (ensure-backend! value session)
|
|
(if (playback-session-backend session)
|
|
(playback-session-backend session)
|
|
(let* ((selected
|
|
(renderer-by-id value
|
|
(playback-session-selected-id session)))
|
|
(_
|
|
(unless selected
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"selected renderer is unavailable"
|
|
"renderer" (playback-session-selected-id session))))
|
|
(kind (renderer-kind selected))
|
|
(_claimed (claim-renderer! value session))
|
|
(backend
|
|
(cond
|
|
((eq? kind 'local)
|
|
(make-local-backend value session))
|
|
((or (eq? kind 'upnp)
|
|
(eq? kind 'sonos))
|
|
(make-network-backend
|
|
value
|
|
session
|
|
(renderer-device selected)))
|
|
((eq? kind 'agent)
|
|
(renderer-device selected))
|
|
(else
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"unsupported renderer kind"
|
|
"kind" kind)))))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-playback-session-backend! session backend)
|
|
(set-playback-session-backend-kind! session kind)))
|
|
backend)))
|
|
|
|
(define (close-backend! value session)
|
|
(let ((backend (playback-session-backend session))
|
|
(kind (playback-session-backend-kind session)))
|
|
(when backend
|
|
(with-handlers
|
|
((exn:fail?
|
|
(λ (exception)
|
|
(warn-web-player
|
|
"Could not close ~a player: ~a"
|
|
kind
|
|
(exn-message exception)))))
|
|
(cond
|
|
((eq? kind 'local)
|
|
(audio-quit! backend))
|
|
((eq? kind 'agent)
|
|
(enqueue-agent-command! value backend "stop"))
|
|
(else
|
|
(dlna-playback-close! backend)))))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-playback-session-backend! session #f)
|
|
(set-playback-session-backend-kind! session #f)
|
|
(set-playback-session-state! session 'stopped)
|
|
(set-playback-session-position! session 0)
|
|
(set-playback-session-duration! session #f)
|
|
(reset-audio-info! session)))))
|
|
|
|
(define (stop-playback! value session)
|
|
(when (playback-session-backend session)
|
|
(cond
|
|
((eq? (playback-session-backend-kind session) 'local)
|
|
(audio-stop! (playback-session-backend session)))
|
|
((eq? (playback-session-backend-kind session) 'agent)
|
|
(enqueue-agent-command! value
|
|
(playback-session-backend session)
|
|
"stop"))
|
|
(else
|
|
(dlna-playback-stop! (playback-session-backend session)))))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-playback-session-state! session 'stopped)
|
|
(set-playback-session-position! session 0)
|
|
(reset-audio-info! session))))
|
|
|
|
(define (valid-track-index? session index)
|
|
(and (exact-nonnegative-integer? index)
|
|
(< index (length (playback-session-tracks session)))))
|
|
|
|
(define (play-index! value session index [defer-current-index? #f])
|
|
(unless (valid-track-index? session index)
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"track index is outside the playlist"
|
|
"index" index))
|
|
(let* ((item (list-ref (playback-session-tracks session) index))
|
|
(backend (ensure-backend! value session))
|
|
(kind (playback-session-backend-kind session)))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(unless defer-current-index?
|
|
(set-playback-session-current-index! session index)
|
|
(set-playback-session-state! session 'starting)
|
|
(set-playback-session-position! session 0)
|
|
(set-playback-session-duration! session (track-duration item)))))
|
|
(cond
|
|
((eq? kind 'local)
|
|
(let ((music-id (audio-play! backend (track-file item))))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(hash-set! (playback-session-local-music-indexes session)
|
|
music-id
|
|
index)))))
|
|
((eq? kind 'agent)
|
|
(let* ((token (fresh-media-token))
|
|
(data (agent-track-data item index token))
|
|
(following-index (next-index session 1))
|
|
(following-item
|
|
(and following-index
|
|
(list-ref (playback-session-tracks session)
|
|
following-index)))
|
|
(following-token
|
|
(and following-item (fresh-media-token)))
|
|
(following-data
|
|
(and following-item
|
|
(agent-track-data following-item
|
|
following-index
|
|
following-token))))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(hash-set! (playback-agent-media backend)
|
|
token
|
|
(track-file item))
|
|
(when following-item
|
|
(hash-set! (playback-agent-media backend)
|
|
following-token
|
|
(track-file following-item)))))
|
|
(enqueue-agent-command! value backend "play" data)
|
|
(when following-data
|
|
(enqueue-agent-command!
|
|
value backend "prefetch" following-data))))
|
|
(else
|
|
(dlna-playback-play-index! backend index)))
|
|
(clear-session-error! value session)))
|
|
|
|
(define (next-index session direction)
|
|
(let ((count (length (playback-session-tracks session)))
|
|
(current (playback-session-current-index session))
|
|
(repeat (playback-session-repeat session)))
|
|
(cond
|
|
((zero? count) #f)
|
|
((eq? repeat 'one) current)
|
|
((eq? current #f)
|
|
(if (positive? direction) 0 (- count 1)))
|
|
(else
|
|
(let ((candidate (+ current direction)))
|
|
(cond
|
|
((and (>= candidate 0) (< candidate count)) candidate)
|
|
((eq? repeat 'all)
|
|
(if (positive? direction) 0 (- count 1)))
|
|
(else #f)))))))
|
|
|
|
(define (refresh-agent-state! value session)
|
|
(define reported
|
|
(playback-agent-reported-state (playback-session-backend session)))
|
|
;; Keep optimistic command state until playback-changing work is acknowledged.
|
|
(when (and (hash? reported)
|
|
(andmap
|
|
(λ (command)
|
|
(string=? (hash-ref command 'action "") "prefetch"))
|
|
(playback-agent-commands
|
|
(playback-session-backend session))))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(let ((state (hash-ref reported 'state #f)))
|
|
(when (string? state)
|
|
(set-playback-session-state!
|
|
session
|
|
(normalize-state (string->symbol state)))))
|
|
(set-playback-session-position!
|
|
session
|
|
(or (json-number reported 'position #f) 0))
|
|
(set-playback-session-duration!
|
|
session
|
|
(json-number reported 'duration #f))
|
|
(set-playback-session-rate!
|
|
session
|
|
(json-number reported 'rate #f))
|
|
(set-playback-session-channels!
|
|
session
|
|
(json-number reported 'channels #f))
|
|
(set-playback-session-bits!
|
|
session
|
|
(json-number reported 'bits #f))
|
|
(let ((decoder (json-string reported 'format #f)))
|
|
(set-playback-session-decoder!
|
|
session
|
|
(and decoder (string->symbol decoder))))
|
|
(let ((volume (json-number reported 'volume #f)))
|
|
(when volume (set-playback-session-volume! session volume)))
|
|
(set-playback-session-error!
|
|
session
|
|
(json-string reported 'error #f))))))
|
|
|
|
(define (refresh-network-state! value session)
|
|
(when (and (playback-session-backend session)
|
|
(eq? (playback-session-backend-kind session) 'agent))
|
|
(with-handlers
|
|
((exn:fail?
|
|
(λ (exception)
|
|
(set-session-error! value session (exn-message exception)))))
|
|
(refresh-agent-state! value session))))
|
|
|
|
(define (entry-by-index value index)
|
|
(and (exact-nonnegative-integer? index)
|
|
(< index (length (player-browser-entries value)))
|
|
(list-ref (player-browser-entries value) index)))
|
|
|
|
(define (refresh-browser! value library relative-path)
|
|
(let ((entries (browse-library library relative-path)))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-player-current-library-id!
|
|
value
|
|
(music-library-id library))
|
|
(set-player-browser-path! value relative-path)
|
|
(set-player-browser-entries! value entries)))))
|
|
|
|
(define (selected-entry-tracks value index)
|
|
(let ((entry (entry-by-index value index))
|
|
(library (current-library value)))
|
|
(unless entry
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"library entry does not exist"
|
|
"index" index))
|
|
(unless library
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"no music library is selected"))
|
|
(browser-entry->tracks library entry)))
|
|
|
|
(define (same-track? first second)
|
|
(equal? (normal-case-path (track-file first))
|
|
(normal-case-path (track-file second))))
|
|
|
|
(define (append-tracks! value session tracks)
|
|
(let ((combined
|
|
(foldl
|
|
(λ (item result)
|
|
(if (findf (λ (existing)
|
|
(same-track? item existing))
|
|
result)
|
|
result
|
|
(append result (list item))))
|
|
(player-tracks value)
|
|
tracks)))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-player-tracks! value combined)
|
|
(set-playback-session-tracks! session combined)
|
|
(save-current-tab! value)
|
|
(persist-playlists! value)))))
|
|
|
|
(define (replace-tracks! value session tracks)
|
|
(stop-playback! value session)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-player-tracks! value tracks)
|
|
(set-playback-session-tracks! session tracks)
|
|
(set-playback-session-current-index! session #f)
|
|
(save-current-tab! value)
|
|
(persist-playlists! value))))
|
|
|
|
(define (drop-track! value session index)
|
|
(unless (valid-track-index? session index)
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"track index is outside the playlist"
|
|
"index" index))
|
|
(when (equal? index (playback-session-current-index session))
|
|
(stop-playback! value session))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-player-tracks!
|
|
value
|
|
(append (take (player-tracks value) index)
|
|
(drop (player-tracks value) (+ index 1))))
|
|
(set-playback-session-tracks! session (player-tracks value))
|
|
(cond
|
|
((equal? index (playback-session-current-index session))
|
|
(set-playback-session-current-index! session #f))
|
|
((and (playback-session-current-index session)
|
|
(< index (playback-session-current-index session)))
|
|
(set-playback-session-current-index!
|
|
session
|
|
(- (playback-session-current-index session) 1))))
|
|
(save-current-tab! value)
|
|
(persist-playlists! value))))
|
|
|
|
(define (move-track! value session from-index to-index)
|
|
(unless (and (valid-track-index? session from-index)
|
|
(valid-track-index? session to-index))
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"track move indexes are outside the playlist"
|
|
"from" from-index
|
|
"to" to-index))
|
|
(unless (= from-index to-index)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(let* ((tracks (player-tracks value))
|
|
(item (list-ref tracks from-index))
|
|
(without
|
|
(append (take tracks from-index)
|
|
(drop tracks (+ from-index 1))))
|
|
(moved
|
|
(append (take without to-index)
|
|
(list item)
|
|
(drop without to-index)))
|
|
(current (playback-session-current-index session)))
|
|
(set-player-tracks! value moved)
|
|
(set-playback-session-tracks! session moved)
|
|
(when current
|
|
(cond
|
|
((= current from-index)
|
|
(set-playback-session-current-index! session to-index))
|
|
((and (< from-index current)
|
|
(<= current to-index))
|
|
(set-playback-session-current-index! session (- current 1)))
|
|
((and (<= to-index current)
|
|
(< current from-index))
|
|
(set-playback-session-current-index! session (+ current 1)))))
|
|
(save-current-tab! value)
|
|
(persist-playlists! value))))))
|
|
|
|
(define (select-tab! value session index)
|
|
(unless (and (exact-nonnegative-integer? index)
|
|
(< index (length (player-tabs value))))
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"playlist tab does not exist"
|
|
"index" index))
|
|
(unless (= index (player-current-tab-index value))
|
|
(stop-playback! value session)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(save-current-tab! value)
|
|
(set-player-current-tab-index! value index)
|
|
(set-player-tracks!
|
|
value
|
|
(playlist-tab-tracks (current-tab value)))
|
|
(set-playback-session-tracks! session (player-tracks value))
|
|
(set-playback-session-current-index! session #f)
|
|
(persist-playlists! value)))))
|
|
|
|
(define (add-tab! value session)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(save-current-tab! value)
|
|
(let* ((tabs (player-tabs value))
|
|
(number (+ (length tabs) 1))
|
|
(tab
|
|
(playlist-tab
|
|
(uuid-string)
|
|
(format "Playlist ~a" number)
|
|
'())))
|
|
(set-player-tabs! value (append tabs (list tab)))
|
|
(set-player-current-tab-index! value (length tabs))
|
|
(set-player-tracks! value '())
|
|
(set-playback-session-tracks! session '())
|
|
(set-playback-session-current-index! session #f)
|
|
(persist-playlists! value)))))
|
|
|
|
(define (rename-tab! value index name)
|
|
(unless (and (exact-nonnegative-integer? index)
|
|
(< index (length (player-tabs value))))
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"playlist tab does not exist"
|
|
"index" index))
|
|
(let ((trimmed (string-trim name)))
|
|
(when (string=? trimmed "")
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"playlist name cannot be empty"))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-playlist-tab-name!
|
|
(list-ref (player-tabs value) index)
|
|
trimmed)
|
|
(persist-playlists! value)))))
|
|
|
|
;;; Close a tab, retaining saved playlists in the user's library.
|
|
(define (delete-tab! value session index)
|
|
(unless (and (exact-nonnegative-integer? index)
|
|
(< index (length (player-tabs value))))
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"playlist tab does not exist"
|
|
"index" index))
|
|
(let ((context (playlist-context-for! value (player-active-playlist-user value))))
|
|
(when (and (= (length (player-tabs value)) 1)
|
|
(not (memq (current-tab value) (playlist-context-saved context))))
|
|
(raise-arguments-error 'player-command! "the last playlist tab cannot be removed")))
|
|
(stop-playback! value session)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(save-current-tab! value)
|
|
(let* ((remaining
|
|
(append (take (player-tabs value) index)
|
|
(drop (player-tabs value) (+ index 1))))
|
|
(tabs (if (pair? remaining) remaining
|
|
(list (playlist-tab (uuid-string) "Default" '()))))
|
|
(new-index
|
|
(min (player-current-tab-index value)
|
|
(- (length tabs) 1))))
|
|
(set-player-tabs! value tabs)
|
|
(set-player-current-tab-index! value new-index)
|
|
(set-player-tracks!
|
|
value
|
|
(playlist-tab-tracks (list-ref tabs new-index)))
|
|
(set-playback-session-tracks! session (player-tracks value))
|
|
(set-playback-session-current-index! session #f)
|
|
(persist-playlists! value)))))
|
|
|
|
;;; Save an open tab in the library once; subsequent tab edits share its identity.
|
|
(define (save-playlist! value id name)
|
|
(let* ((context (playlist-context-for! value (player-active-playlist-user value)))
|
|
(tab (findf (λ (tab) (equal? (playlist-tab-id tab) id)) (player-tabs value)))
|
|
(trimmed (string-trim name)))
|
|
(unless tab
|
|
(raise-arguments-error 'player-command! "playlist tab does not exist" "id" id))
|
|
(when (string=? trimmed "")
|
|
(raise-arguments-error 'player-command! "playlist name cannot be empty"))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(save-current-tab! value)
|
|
(set-playlist-tab-name! tab trimmed)
|
|
(unless (memq tab (playlist-context-saved context))
|
|
(set-playlist-context-saved! context
|
|
(append (playlist-context-saved context) (list tab))))
|
|
(persist-playlists! value)))))
|
|
|
|
;;; Reveal a saved playlist as its own tab, reusing an existing tab by identity.
|
|
;;; Opening never copies tracks into another tab; play? starts this playlist.
|
|
(define (open-playlist! value session id play?)
|
|
(let* ((context (playlist-context-for! value (player-active-playlist-user value)))
|
|
(tab (findf (λ (tab) (equal? (playlist-tab-id tab) id))
|
|
(playlist-context-saved context))))
|
|
(unless tab
|
|
(raise-arguments-error 'player-command! "saved playlist does not exist" "id" id))
|
|
(let ((index (index-of (player-tabs value) tab eq?)))
|
|
(unless index
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(save-current-tab! value)
|
|
(set-player-tabs! value (append (player-tabs value) (list tab))))))
|
|
(select-tab! value session (or index (- (length (player-tabs value)) 1)))))
|
|
(when (and play? (pair? (player-tracks value)))
|
|
(play-index! value session 0)))
|
|
|
|
(define (track->jsexpr item index)
|
|
(hasheq 'index index
|
|
'title (track-title item)
|
|
'artist (track-artist item)
|
|
'album (track-album item)
|
|
'duration (or (track-duration item) 'null)
|
|
'mimeType (track-mime-type item)
|
|
'artworkId (track-cache-key item)
|
|
'source (path->string
|
|
(or (file-name-from-path (track-file item))
|
|
(track-file item)))))
|
|
|
|
(define (renderer->jsexpr item)
|
|
(hasheq 'id (renderer-id item)
|
|
'name (renderer-name item)
|
|
'kind (symbol->string (renderer-kind item))))
|
|
|
|
(define (library->jsexpr library)
|
|
(hasheq 'id (music-library-id library)
|
|
'name (music-library-name library)))
|
|
|
|
(define (browser-entry->jsexpr entry index)
|
|
(hasheq 'index index
|
|
'name (browser-entry-name entry)
|
|
'kind (symbol->string (browser-entry-kind entry))))
|
|
|
|
;;; Cache serialized tracks and their summary until save-current-tab! invalidates
|
|
;;; them. A fresh opaque version also prevents cache reuse across server restarts.
|
|
(define (tab-snapshot tab)
|
|
(or (playlist-tab-snapshot tab)
|
|
(let* ((tracks (playlist-tab-tracks tab))
|
|
(snapshot
|
|
(hasheq 'version (uuid-string)
|
|
'count (length tracks)
|
|
'duration (apply + (map (λ (item) (or (track-duration item) 0))
|
|
tracks))
|
|
'tracks (map track->jsexpr tracks (range (length tracks))))))
|
|
(set-playlist-tab-snapshot! tab snapshot)
|
|
snapshot)))
|
|
|
|
;;; Return a small tab summary without rebuilding or transferring its tracks.
|
|
(define (tab->jsexpr tab index [saved? #f])
|
|
(let ((snapshot (tab-snapshot tab)))
|
|
(hasheq 'index index
|
|
'id (playlist-tab-id tab)
|
|
'name (playlist-tab-name tab)
|
|
'saved saved?
|
|
'count (hash-ref snapshot 'count)
|
|
'duration (hash-ref snapshot 'duration))))
|
|
|
|
(define (normal-device-id device)
|
|
(let ((id (upnp-device-udn device)))
|
|
(and id
|
|
(let ((match
|
|
(regexp-match
|
|
#px"(?i:RINCON_[0-9A-F]+)"
|
|
id)))
|
|
(if match
|
|
(string-upcase (car match))
|
|
(regexp-replace #px"(?i:^uuid:)" id ""))))))
|
|
|
|
(define (sonos-member? device member-ids)
|
|
(let ((id (normal-device-id device)))
|
|
(and id
|
|
(ormap (λ (member-id)
|
|
(string-ci=? id member-id))
|
|
member-ids))))
|
|
|
|
(define (discover-renderers)
|
|
(let* ((devices (query-upnp-devices 'all))
|
|
(media-renderers (filter media-renderer? devices))
|
|
(groups
|
|
(with-handlers
|
|
((exn:fail?
|
|
(λ (exception)
|
|
(warn-web-player
|
|
"Could not read Sonos topology: ~a"
|
|
(exn-message exception))
|
|
'())))
|
|
(sonos-groups devices)))
|
|
(member-ids
|
|
(append-map sonos-group-member-ids groups))
|
|
(upnp-renderers
|
|
(for/list ((device (in-list media-renderers))
|
|
#:unless (sonos-member? device member-ids))
|
|
(renderer
|
|
(format "upnp:~a"
|
|
(or (upnp-device-udn device)
|
|
(media-renderer-address device)))
|
|
(if (sonos-device? device)
|
|
(sonos-device-name device)
|
|
(media-renderer-name device))
|
|
'upnp
|
|
device)))
|
|
(sonos-renderers
|
|
(for/list ((group (in-list groups)))
|
|
(renderer
|
|
(format "sonos:~a" (sonos-group-id group))
|
|
(sonos-group-name group)
|
|
'sonos
|
|
(sonos-group-renderer group)))))
|
|
(sort (append upnp-renderers sonos-renderers)
|
|
string-ci<?
|
|
#:key renderer-name)))
|
|
|
|
(define (json-number data key [default #f])
|
|
(let ((value (hash-ref data key default)))
|
|
(if (number? value) value default)))
|
|
|
|
(define (json-string data key [default #f])
|
|
(let ((value (hash-ref data key default)))
|
|
(if (string? value) value default)))
|
|
|
|
(define (perform-library-command! value session command data)
|
|
(let ((index (json-number data 'index #f)))
|
|
(cond
|
|
((string=? command "library")
|
|
(let* ((id (json-string data 'id #f))
|
|
(library (and id (library-by-id value id))))
|
|
(unless library
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"music library does not exist"
|
|
"id" id))
|
|
(refresh-browser! value library '())))
|
|
((string=? command "browse")
|
|
(let ((entry (entry-by-index value index)))
|
|
(unless (and entry
|
|
(eq? (browser-entry-kind entry) 'container))
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"library entry is not a directory"
|
|
"index" index))
|
|
(refresh-browser!
|
|
value
|
|
(current-library value)
|
|
(browser-entry-relative-path entry))))
|
|
((string=? command "up")
|
|
(unless (null? (player-browser-path value))
|
|
(refresh-browser!
|
|
value
|
|
(current-library value)
|
|
(drop-right (player-browser-path value) 1))))
|
|
((string=? command "item-play")
|
|
(let ((tracks (selected-entry-tracks value index)))
|
|
(when (null? tracks)
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"selected item contains no supported audio"))
|
|
(replace-tracks! value session tracks)
|
|
(play-index! value session 0)))
|
|
((string=? command "item-add")
|
|
(append-tracks!
|
|
value
|
|
session
|
|
(selected-entry-tracks value index))))))
|
|
|
|
(define (perform-playlist-command! value session command data)
|
|
(let ((index (json-number data 'index #f)))
|
|
(cond
|
|
((string=? command "track-remove")
|
|
(drop-track! value session index))
|
|
((string=? command "track-move")
|
|
(move-track! value
|
|
session
|
|
(json-number data 'from #f)
|
|
(json-number data 'to #f)))
|
|
((string=? command "playlist-clear")
|
|
(replace-tracks! value session '()))
|
|
((string=? command "tab-add")
|
|
(stop-playback! value session)
|
|
(add-tab! value session))
|
|
((string=? command "tab-select")
|
|
(select-tab! value session index))
|
|
((string=? command "tab-rename")
|
|
(rename-tab! value index
|
|
(or (json-string data 'name #f) "")))
|
|
((string=? command "tab-delete")
|
|
(delete-tab! value session index))
|
|
((string=? command "playlist-save")
|
|
(save-playlist! value (json-string data 'id #f) (or (json-string data 'name #f) "")))
|
|
((member command '("playlist-open" "playlist-play"))
|
|
(open-playlist! value session (json-string data 'id #f)
|
|
(string=? command "playlist-play"))))))
|
|
|
|
(define (perform-command! value session command data)
|
|
(cond
|
|
((member command '("library" "browse" "up"
|
|
"item-play" "item-add"))
|
|
(perform-library-command! value session command data))
|
|
((member command '("track-remove" "track-move"
|
|
"playlist-clear" "tab-add"
|
|
"tab-select" "tab-rename"
|
|
"tab-delete" "playlist-save" "playlist-open" "playlist-play"))
|
|
(perform-playlist-command! value session command data))
|
|
((string=? command "play")
|
|
(play-index!
|
|
value
|
|
session
|
|
(or (json-number data 'index #f)
|
|
(playback-session-current-index session)
|
|
0)))
|
|
((string=? command "pause")
|
|
(let ((backend (ensure-backend! value session)))
|
|
(cond
|
|
((eq? (playback-session-backend-kind session) 'local)
|
|
(audio-pause! backend #t))
|
|
((eq? (playback-session-backend-kind session) 'agent)
|
|
(enqueue-agent-command! value backend "pause"))
|
|
(else
|
|
(dlna-playback-pause! backend)))))
|
|
((string=? command "resume")
|
|
(let ((backend (ensure-backend! value session)))
|
|
(cond
|
|
((eq? (playback-session-backend-kind session) 'local)
|
|
(audio-pause! backend #f))
|
|
((eq? (playback-session-backend-kind session) 'agent)
|
|
(enqueue-agent-command! value backend "resume"))
|
|
(else
|
|
(dlna-playback-resume! backend)))))
|
|
((string=? command "stop")
|
|
(stop-playback! value session))
|
|
((string=? command "next")
|
|
(let ((index (next-index session 1)))
|
|
(if index
|
|
(play-index! value session index)
|
|
(stop-playback! value session))))
|
|
((string=? command "previous")
|
|
(let ((index (next-index session -1)))
|
|
(when index
|
|
(play-index! value session index))))
|
|
((string=? command "seek")
|
|
(let ((percentage (json-number data 'percentage #f)))
|
|
(unless percentage
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"seek requires a numeric percentage"))
|
|
(let ((backend (ensure-backend! value session)))
|
|
(cond
|
|
((eq? (playback-session-backend-kind session) 'local)
|
|
(audio-seek! backend percentage))
|
|
((eq? (playback-session-backend-kind session) 'agent)
|
|
(enqueue-agent-command!
|
|
value backend "seek"
|
|
(hasheq 'percentage percentage)))
|
|
(else
|
|
(dlna-playback-seek-percentage! backend percentage))))))
|
|
((string=? command "volume")
|
|
(let ((percentage (json-number data 'value #f)))
|
|
(unless percentage
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"volume requires a numeric value"))
|
|
(let* ((clamped (min 100 (max 0 percentage)))
|
|
(backend (ensure-backend! value session)))
|
|
(cond
|
|
((eq? (playback-session-backend-kind session) 'local)
|
|
(let ((logical-volume (/ clamped 100.0)))
|
|
(audio-volume!
|
|
backend
|
|
(* 100.0 logical-volume logical-volume))))
|
|
((eq? (playback-session-backend-kind session) 'agent)
|
|
(enqueue-agent-command!
|
|
value backend "volume"
|
|
(hasheq 'value clamped)))
|
|
(else
|
|
(dlna-playback-volume! backend clamped)))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-playback-session-volume! session clamped))))))
|
|
((string=? command "repeat")
|
|
(let* ((name (json-string data 'mode "off"))
|
|
(mode (string->symbol name)))
|
|
(unless (member mode '(off all one))
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"repeat mode must be off, all, or one"
|
|
"mode" name))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-playback-session-repeat! session mode)))
|
|
(when (member (playback-session-backend-kind session) '(upnp sonos))
|
|
(dlna-playback-repeat!
|
|
(playback-session-backend session)
|
|
mode))))
|
|
((string=? command "renderer")
|
|
(let* ((id (json-string data 'id #f))
|
|
(selected (and id (renderer-by-id value id))))
|
|
(unless selected
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"renderer does not exist"
|
|
"id" id))
|
|
(unless (equal? id (playback-session-selected-id session))
|
|
(let ((old-id (playback-session-selected-id session)))
|
|
(close-backend! value session)
|
|
(when (eq? (hash-ref (player-renderer-owners value) old-id #f)
|
|
session)
|
|
(hash-remove! (player-renderer-owners value) old-id)))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-playback-session-selected-id! session id)))
|
|
(claim-renderer! value session))))
|
|
(else
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"unknown player command"
|
|
"command" command))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create a player for lazily browsed music libraries.
|
|
; pre : Libraries are valid, allowed agent IDs are 256-bit hex strings, and
|
|
; local-output? is a boolean.
|
|
; post : Only the selected root directory has been listed; no backend exists.
|
|
; result : A player that initially selects local playback when it is enabled;
|
|
; otherwise no renderer is selected until one becomes available.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (make-player libraries
|
|
#:allowed-agent-ids [allowed-agent-ids '()]
|
|
#:local-output? [local-output? #t]
|
|
#:playlist-keystore [playlist-keystore #f]
|
|
#:dlna-port [dlna-port 8734])
|
|
(unless (boolean? local-output?)
|
|
(raise-argument-error 'make-player "boolean?" local-output?))
|
|
(define normalized-agent-ids
|
|
(for/list ((app-id (in-list allowed-agent-ids)))
|
|
(unless (valid-agent-id? app-id)
|
|
(raise-argument-error
|
|
'make-player
|
|
"64-character hexadecimal playback agent id"
|
|
app-id))
|
|
(string-downcase app-id)))
|
|
(define store (open-playlist-store playlist-keystore))
|
|
(let* ((library (and (pair? libraries) (car libraries)))
|
|
(browser-entries
|
|
(if library
|
|
(browse-library library '())
|
|
'()))
|
|
(initial-context (restore-playlist-context store "anonymous" libraries))
|
|
(tabs (playlist-context-tabs initial-context))
|
|
(selected-index 0)
|
|
(contexts (make-hash)))
|
|
(hash-set! contexts "anonymous" initial-context)
|
|
(define value
|
|
(player libraries
|
|
(remove-duplicates normalized-agent-ids string=?)
|
|
'()
|
|
(and library (music-library-id library))
|
|
'()
|
|
browser-entries
|
|
(playlist-tab-tracks (list-ref tabs selected-index))
|
|
tabs
|
|
selected-index
|
|
(if local-output?
|
|
(list (renderer "local" "Server audio output" 'local #f))
|
|
'())
|
|
#f
|
|
#f
|
|
#f
|
|
(make-semaphore 1)
|
|
(make-semaphore 1)
|
|
store
|
|
contexts
|
|
"anonymous"
|
|
dlna-port
|
|
(make-hash)
|
|
(make-hash)
|
|
#f))
|
|
value))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Return browser-visible state, optionally reusing known playlist tracks.
|
|
; pre : Value was created with make-player.
|
|
; post : Cached DLNA playback information has been incorporated.
|
|
; result : A JSON-compatible hash with playlistVersion. tracks is null when
|
|
; playlist-version matches; otherwise it contains the complete list.
|
|
; internals: tab-snapshot caches track JSON, duration and a unique version until
|
|
; a playlist mutation invalidates it. Comparison and state assembly
|
|
; share the player locks, so the version always matches the tracks.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (player-state->jsexpr value #:username [username "anonymous"]
|
|
#:playlist-version [playlist-version #f])
|
|
(define normalized (normal-playlist-username username))
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(prune-stale-agents! value)
|
|
(define session (playback-session-for! value normalized))
|
|
(refresh-network-state! value session)
|
|
(define context (playlist-context-for! value normalized))
|
|
(define tabs (playlist-context-tabs context))
|
|
(define tab-index (playlist-context-current-index context))
|
|
(define snapshot (tab-snapshot (list-ref tabs tab-index)))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(let ((current
|
|
(and (playback-session-current-index session)
|
|
(valid-track-index?
|
|
session
|
|
(playback-session-current-index session))
|
|
(list-ref (playback-session-tracks session)
|
|
(playback-session-current-index session)))))
|
|
(hasheq
|
|
'libraries (map library->jsexpr
|
|
(player-libraries value))
|
|
'libraryId (or (player-current-library-id value) 'null)
|
|
'browser
|
|
(hasheq
|
|
'path (map path->string (player-browser-path value))
|
|
'canGoUp (not (null? (player-browser-path value)))
|
|
'entries
|
|
(for/list ((entry (in-list (player-browser-entries value)))
|
|
(index (in-naturals)))
|
|
(browser-entry->jsexpr entry index)))
|
|
'tabs
|
|
(for/list ((tab (in-list tabs))
|
|
(index (in-naturals)))
|
|
(tab->jsexpr tab index (and (memq tab (playlist-context-saved context)) #t)))
|
|
'savedPlaylists
|
|
(map (λ (tab index) (tab->jsexpr tab index #t))
|
|
(playlist-context-saved context)
|
|
(range (length (playlist-context-saved context))))
|
|
'currentTab tab-index
|
|
'playlistVersion (hash-ref snapshot 'version)
|
|
'tracks
|
|
(if (equal? playlist-version (hash-ref snapshot 'version))
|
|
'null
|
|
(hash-ref snapshot 'tracks))
|
|
'renderers (map renderer->jsexpr
|
|
(player-renderers value))
|
|
'rendererId (or (playback-session-selected-id session) 'null)
|
|
'currentIndex (or (playback-session-current-index session) 'null)
|
|
'state (symbol->string (playback-session-state session))
|
|
'position (playback-session-position session)
|
|
'duration (or (playback-session-duration session) 'null)
|
|
'rate (or (playback-session-rate session) 'null)
|
|
'channels (or (playback-session-channels session) 'null)
|
|
'bits (or (playback-session-bits session) 'null)
|
|
'format (if (playback-session-decoder session)
|
|
(format "~a" (playback-session-decoder session))
|
|
"")
|
|
'source (if current
|
|
(path->string
|
|
(or (file-name-from-path (track-file current))
|
|
(track-file current)))
|
|
"")
|
|
'volume (playback-session-volume session)
|
|
'repeat (symbol->string (playback-session-repeat session))
|
|
'discovering (player-discovering? value)
|
|
'error (error->jsexpr
|
|
(or (playback-session-error session)
|
|
(player-error value))))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Execute one browser player command.
|
|
; pre : Command is a string and data is a JSON object hash.
|
|
; post : The command has completed or a concrete exception is raised.
|
|
; result : The updated JSON-compatible player state. With a matching
|
|
; playlist-version, tracks is null as in player-state->jsexpr.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define playlist-context-commands
|
|
'("item-play" "item-add" "track-remove" "track-move"
|
|
"playlist-clear" "tab-add" "tab-select" "tab-rename"
|
|
"tab-delete" "playlist-save" "playlist-open" "playlist-play" "play"))
|
|
|
|
(define (player-command! value command data #:username [username "anonymous"]
|
|
#:playlist-version [playlist-version #f])
|
|
(define normalized (normal-playlist-username username))
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(define session (playback-session-for! value normalized))
|
|
(when (player-closed? value)
|
|
(raise-arguments-error
|
|
'player-command!
|
|
"player has been closed"))
|
|
(with-handlers
|
|
((exn:fail?
|
|
(λ (exception)
|
|
(set-session-error! value session (exn-message exception))
|
|
(raise exception))))
|
|
(when (member command playlist-context-commands)
|
|
(activate-playlist-user! value normalized session))
|
|
(perform-command! value session command data))))
|
|
(player-state->jsexpr value #:username normalized
|
|
#:playlist-version playlist-version))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Discover UPnP renderers and logical Sonos groups asynchronously.
|
|
; pre : Value was created with make-player.
|
|
; post : The renderer list is updated when discovery finishes.
|
|
; result : #t when discovery started, #f when it was already running.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (player-discover! value)
|
|
(let ((can-start?
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(if (player-discovering? value)
|
|
#f
|
|
(begin
|
|
(set-player-discovering?! value #t)
|
|
#t))))))
|
|
(when can-start?
|
|
(thread
|
|
(λ ()
|
|
(with-handlers
|
|
((exn:fail?
|
|
(λ (exception)
|
|
(set-error! value (exn-message exception)))))
|
|
(let ((found (discover-renderers)))
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(let ((outputs
|
|
(append
|
|
(filter (λ (item)
|
|
(eq? (renderer-kind item) 'local))
|
|
(player-renderers value))
|
|
found
|
|
(filter (λ (item)
|
|
(eq? (renderer-kind item) 'agent))
|
|
(player-renderers value)))))
|
|
(set-player-renderers! value outputs)
|
|
(for ((session
|
|
(in-hash-values
|
|
(player-playback-sessions value))))
|
|
(unless (renderer-by-id
|
|
value
|
|
(playback-session-selected-id session))
|
|
(define old-id
|
|
(playback-session-selected-id session))
|
|
(close-backend! value session)
|
|
(when (and old-id
|
|
(eq? session
|
|
(hash-ref
|
|
(player-renderer-owners value)
|
|
old-id
|
|
#f)))
|
|
(hash-remove! (player-renderer-owners value)
|
|
old-id))
|
|
(set-playback-session-selected-id!
|
|
session
|
|
(and (pair? outputs)
|
|
(renderer-id (car outputs))))))
|
|
(set-player-error! value #f))))))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-player-discovering?! value #f))))))
|
|
can-start?))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Register or refresh one polling playback agent.
|
|
; pre : Data contains an allowlisted 256-bit hexadecimal application id.
|
|
; post : The agent is available as a renderer under its advertised name.
|
|
; result : Agent configuration for the polling client.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (player-agent-register! value data)
|
|
(let* ((supplied-app-id (json-string data 'appId #f))
|
|
(app-id (normal-agent-id supplied-app-id))
|
|
(suggested-name
|
|
(string-trim
|
|
(or (json-string data 'name #f)
|
|
"RKT playback agent")))
|
|
(advertised-name
|
|
(if (string=? suggested-name "")
|
|
"RKT playback agent"
|
|
suggested-name)))
|
|
(unless app-id
|
|
(raise-arguments-error
|
|
'player-agent-register!
|
|
"appId must contain exactly 64 hexadecimal characters"
|
|
"appId" supplied-app-id))
|
|
(require-authorized-agent! value app-id)
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(let ((existing (agent-by-id value app-id)))
|
|
(if existing
|
|
(begin
|
|
(set-playback-agent-name! existing advertised-name)
|
|
(let ((agent-output (agent-renderer value existing)))
|
|
(when agent-output
|
|
(set-renderer-name! agent-output advertised-name)))
|
|
(set-playback-agent-last-seen!
|
|
existing
|
|
(current-seconds))
|
|
(hasheq 'name (playback-agent-name existing)
|
|
'pollIntervalMs 1000))
|
|
(let* ((name advertised-name)
|
|
(agent
|
|
(playback-agent
|
|
app-id name (current-seconds)
|
|
(hasheq 'state "stopped"
|
|
'position 0
|
|
'volume 50)
|
|
'() 1 (make-hash) 0)))
|
|
(set-player-agents!
|
|
value
|
|
(append (player-agents value) (list agent)))
|
|
(set-player-renderers!
|
|
value
|
|
(append
|
|
(player-renderers value)
|
|
(list (renderer (agent-renderer-id app-id)
|
|
name
|
|
'agent
|
|
agent))))
|
|
(for ((session
|
|
(in-hash-values
|
|
(player-playback-sessions value))))
|
|
(unless (playback-session-selected-id session)
|
|
(set-playback-session-selected-id!
|
|
session
|
|
(agent-renderer-id app-id))))
|
|
(hasheq 'name name
|
|
'pollIntervalMs 1000))))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Accept agent state and return its oldest unacknowledged command.
|
|
; pre : The agent was registered with player-agent-register!.
|
|
; post : State, heartbeat, acknowledgements and end-of-track are incorporated.
|
|
; result : Poll response containing the current agent name and optional command.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (player-agent-poll! value data)
|
|
(let* ((supplied-app-id (json-string data 'appId #f))
|
|
(app-id (normal-agent-id supplied-app-id))
|
|
(name (json-string data 'name #f)))
|
|
(unless app-id
|
|
(raise-arguments-error
|
|
'player-agent-poll!
|
|
"appId must contain exactly 64 hexadecimal characters"
|
|
"appId" supplied-app-id))
|
|
(require-authorized-agent! value app-id)
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(let ((agent (agent-by-id value app-id)))
|
|
(unless agent
|
|
(raise-arguments-error
|
|
'player-agent-poll!
|
|
"playback agent is not registered"
|
|
"appId" app-id))
|
|
(let* ((ack (json-number data 'ack #f))
|
|
(reported (hash-ref data 'state #f))
|
|
(ended (json-number data 'endedCounter 0))
|
|
(previous-ended
|
|
(playback-agent-ended-counter agent)))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-playback-agent-last-seen! agent (current-seconds))
|
|
(when (and name
|
|
(not (string=? (string-trim name) "")))
|
|
(let ((trimmed (string-trim name))
|
|
(agent-output (agent-renderer value agent)))
|
|
(set-playback-agent-name! agent trimmed)
|
|
(when agent-output
|
|
(set-renderer-name! agent-output trimmed))))
|
|
(when (hash? reported)
|
|
(set-playback-agent-reported-state! agent reported))
|
|
(when (exact-nonnegative-integer? ack)
|
|
(for ((command (in-list (playback-agent-commands agent)))
|
|
#:when (<= (hash-ref command 'id) ack))
|
|
(let* ((command-data
|
|
(hash-ref command 'data (hasheq)))
|
|
(media-token
|
|
(hash-ref command-data 'mediaToken #f)))
|
|
(when (string? media-token)
|
|
(hash-remove! (playback-agent-media agent)
|
|
media-token))))
|
|
(set-playback-agent-commands!
|
|
agent
|
|
(filter
|
|
(λ (command)
|
|
(> (hash-ref command 'id) ack))
|
|
(playback-agent-commands agent))))
|
|
(when (exact-nonnegative-integer? ended)
|
|
(set-playback-agent-ended-counter! agent ended))))
|
|
(define owner
|
|
(hash-ref (player-renderer-owners value)
|
|
(agent-renderer-id app-id)
|
|
#f))
|
|
(when (and (> ended previous-ended)
|
|
owner
|
|
(eq? (playback-session-backend owner) agent))
|
|
(let ((index (next-index owner 1)))
|
|
(if index
|
|
(play-index! value owner index)
|
|
(stop-playback! value owner))))
|
|
(hasheq
|
|
'name (playback-agent-name agent)
|
|
'command
|
|
(if (null? (playback-agent-commands agent))
|
|
'null
|
|
(car (playback-agent-commands agent))))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Resolve the current opaque media token for one playback agent.
|
|
; pre : App id and token came from a play command returned by agent polling.
|
|
; post : No state changes.
|
|
; result : The local track path, or #f when the token is invalid or expired.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (player-agent-media value app-id token)
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(let* ((normalized (normal-agent-id app-id))
|
|
(agent (and normalized
|
|
(authorized-agent-id? value normalized)
|
|
(agent-by-id value normalized))))
|
|
(and agent
|
|
(string? token)
|
|
(hash-ref (playback-agent-media agent) token #f))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Resolve an opaque playlist artwork id.
|
|
; pre : Artwork id came from player-state->jsexpr.
|
|
; post : Player state remains unchanged.
|
|
; result : Artwork bytes and MIME type, or #f when unavailable.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (player-track-artwork value artwork-id #:username [username "anonymous"])
|
|
(define item
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(define context
|
|
(playlist-context-for!
|
|
value
|
|
(normal-playlist-username username)))
|
|
(define candidates
|
|
(append
|
|
(player-tracks value)
|
|
(append-map playlist-tab-tracks
|
|
(playlist-context-tabs context))))
|
|
(findf (λ (candidate)
|
|
(string=? (track-cache-key candidate) artwork-id))
|
|
candidates))))
|
|
(and item (track-artwork item)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Load one user's persisted web-interface language.
|
|
; pre : Value was created with make-player.
|
|
; post : Player and keystore state remain unchanged.
|
|
; result : A supported ISO language name, or #f when no preference was saved.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (player-user-language value #:username [username "anonymous"])
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(load-user-language
|
|
(player-playlist-store value)
|
|
(normal-playlist-username username)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Persist one user's web-interface language.
|
|
; pre : Value was created with make-player; language is supported.
|
|
; post : The language preference is durable when a keystore is configured.
|
|
; result : Void.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (player-user-language! value language
|
|
#:username [username "anonymous"])
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(save-user-language!
|
|
(player-playlist-store value)
|
|
(normal-playlist-username username)
|
|
language))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Stop playback and release all player resources.
|
|
; pre : Value was created with make-player.
|
|
; post : All backends and the shared media server are closed; repeated calls
|
|
; are harmless.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (player-close! value)
|
|
(call-with-semaphore
|
|
(player-command-lock value)
|
|
(λ ()
|
|
(unless (player-closed? value)
|
|
(for ((session
|
|
(in-hash-values (player-playback-sessions value))))
|
|
(close-backend! value session))
|
|
(when (player-media-file-server value)
|
|
(media-file-server-stop! (player-media-file-server value))
|
|
(set-player-media-file-server! value #f))
|
|
(hash-clear! (player-renderer-owners value))
|
|
(close-playlist-store! (player-playlist-store value))
|
|
(with-state-lock
|
|
value
|
|
(λ ()
|
|
(set-player-closed?! value #t)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Tests for module player.rkt
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(module+ test
|
|
(require json
|
|
rackunit
|
|
racket/file)
|
|
|
|
(test-case "playlist versions cache 1000 tracks and follow user mutations"
|
|
(let ((value (make-player '() #:playlist-keystore #f #:local-output? #f)))
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(let* ((session (playback-session-for! value "anonymous"))
|
|
(tracks
|
|
(build-list
|
|
1000
|
|
(λ (index)
|
|
(track (build-path (find-system-path 'temp-dir)
|
|
(format "playlist-test-~a.flac" index))
|
|
(format "Track ~a" index) "Artist" "Album" 60 "audio/flac")))))
|
|
(replace-tracks! value session tracks)
|
|
(let* ((full (player-state->jsexpr value))
|
|
(version (hash-ref full 'playlistVersion))
|
|
(compact (player-state->jsexpr value #:playlist-version version))
|
|
(repeated (player-state->jsexpr value)))
|
|
(check-equal? (length (hash-ref full 'tracks)) 1000)
|
|
(check-equal? (hash-ref (car (hash-ref full 'tabs)) 'duration) 60000)
|
|
(check-eq? (hash-ref compact 'tracks) 'null)
|
|
(check-eq? (hash-ref full 'tracks) (hash-ref repeated 'tracks))
|
|
(check-true (< (bytes-length (jsexpr->bytes compact))
|
|
(/ (bytes-length (jsexpr->bytes full)) 20)))
|
|
(check-eq?
|
|
(hash-ref (player-command! value "repeat" (hasheq 'mode "all")
|
|
#:playlist-version version) 'tracks)
|
|
'null)
|
|
(check-eq?
|
|
(hash-ref (player-command! value "tab-rename" (hasheq 'index 0 'name "Music")
|
|
#:playlist-version version) 'tracks)
|
|
'null)
|
|
(let* ((moved (player-command! value "track-move" (hasheq 'from 0 'to 1)
|
|
#:playlist-version version))
|
|
(moved-version (hash-ref moved 'playlistVersion))
|
|
(other-browser (player-state->jsexpr value #:playlist-version version)))
|
|
(check-not-equal? moved-version version)
|
|
(check-equal? (hash-ref (car (hash-ref moved 'tracks)) 'title) "Track 1")
|
|
(check-equal? (hash-ref other-browser 'playlistVersion) moved-version)
|
|
(check-equal? (hash-ref other-browser 'tracks) (hash-ref moved 'tracks))
|
|
(let* ((removed (player-command! value "track-remove" (hasheq 'index 0)
|
|
#:playlist-version moved-version))
|
|
(removed-version (hash-ref removed 'playlistVersion))
|
|
(new-tab (player-command! value "tab-add" (hasheq)
|
|
#:playlist-version removed-version))
|
|
(selected (player-command! value "tab-select" (hasheq 'index 0)
|
|
#:playlist-version (hash-ref new-tab 'playlistVersion))))
|
|
(check-equal? (length (hash-ref removed 'tracks)) 999)
|
|
(check-not-equal? removed-version moved-version)
|
|
(check-equal? (hash-ref new-tab 'tracks) '())
|
|
(check-equal? (hash-ref selected 'playlistVersion) removed-version)
|
|
(check-equal? (length (hash-ref selected 'tracks)) 999)
|
|
(let ((other-user (player-state->jsexpr value #:username "another-user"
|
|
#:playlist-version removed-version))
|
|
(cleared (player-command! value "playlist-clear" (hasheq)
|
|
#:playlist-version removed-version)))
|
|
(check-equal? (hash-ref other-user 'tracks) '())
|
|
(check-not-equal? (hash-ref other-user 'playlistVersion) removed-version)
|
|
(check-equal? (hash-ref cleared 'tracks) '())
|
|
(check-not-equal? (hash-ref cleared 'playlistVersion) removed-version)
|
|
(append-tracks! value session (list (car tracks)))
|
|
(let* ((added (player-state->jsexpr value
|
|
#:playlist-version (hash-ref cleared 'playlistVersion)))
|
|
(added-version (hash-ref added 'playlistVersion)))
|
|
(check-equal? (length (hash-ref added 'tracks)) 1)
|
|
(check-equal? (hash-ref (car (hash-ref added 'tabs)) 'duration) 60)
|
|
(append-tracks! value session (list (car tracks)))
|
|
(check-eq? (hash-ref (player-state->jsexpr value #:playlist-version added-version)
|
|
'tracks)
|
|
'null))))))))
|
|
(λ () (player-close! value)))))
|
|
|
|
(check-equal? (error->jsexpr #f) 'null)
|
|
(check-equal?
|
|
(error->jsexpr 'dlna-renderer-unreachable)
|
|
"dlna-renderer-unreachable")
|
|
(check-equal? (error->jsexpr "technical error") "technical error")
|
|
|
|
(test-case "saved playlists reopen as shared tabs and survive closing and restart"
|
|
(let ((root (make-temporary-file "saved-playlists-~a" 'directory)))
|
|
(dynamic-wind
|
|
(λ ()
|
|
(call-with-output-file (build-path root "one.flac") void)
|
|
(call-with-output-file (build-path root "two.flac") void))
|
|
(λ ()
|
|
(let* ((libraries (make-music-libraries (list root)))
|
|
(store-file (build-path root "playlists.keystore"))
|
|
(agent-id (make-string 64 #\b))
|
|
(value (make-player libraries #:playlist-keystore store-file
|
|
#:local-output? #f #:allowed-agent-ids (list agent-id)))
|
|
(session (playback-session-for! value "anonymous"))
|
|
(first (track (build-path root "one.flac") "One" "Artist" "Album" 60 "audio/flac"))
|
|
(second (track (build-path root "two.flac") "Two" "Artist" "Album" 120 "audio/flac")))
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(replace-tracks! value session (list first second))
|
|
(let* ((initial (player-state->jsexpr value))
|
|
(id (hash-ref (car (hash-ref initial 'tabs)) 'id))
|
|
(version (hash-ref initial 'playlistVersion))
|
|
(saved (player-command! value "playlist-save" (hasheq 'id id 'name "Favorites")
|
|
#:playlist-version version)))
|
|
(check-equal? (hash-ref initial 'savedPlaylists) '())
|
|
(check-eq? (hash-ref saved 'tracks) 'null)
|
|
(check-true (hash-ref (car (hash-ref saved 'tabs)) 'saved))
|
|
(check-equal? (hash-ref (car (hash-ref saved 'savedPlaylists)) 'id) id)
|
|
(check-equal? (hash-ref (car (hash-ref saved 'savedPlaylists)) 'duration) 180)
|
|
(check-equal?
|
|
(length (hash-ref (player-command! value "playlist-save" (hasheq 'id id 'name "Favorites"))
|
|
'savedPlaylists)) 1)
|
|
(player-command! value "tab-add" (hasheq))
|
|
(replace-tracks! value session (list first))
|
|
(let ((opened (player-command! value "playlist-open" (hasheq 'id id))))
|
|
(check-equal? (length (hash-ref opened 'tabs)) 2)
|
|
(check-equal? (hash-ref opened 'currentTab) 0)
|
|
(check-equal? (map track-title (playlist-tab-tracks (list-ref (player-tabs value) 1))) '("One"))
|
|
(check-equal? (length (hash-ref (player-command! value "playlist-open" (hasheq 'id id)) 'tabs)) 2))
|
|
(player-command! value "tab-rename" (hasheq 'index 0 'name "Renamed"))
|
|
(let ((edited (player-command! value "track-remove" (hasheq 'index 0))))
|
|
(check-equal? (hash-ref (car (hash-ref edited 'savedPlaylists)) 'name) "Renamed")
|
|
(check-equal? (hash-ref (car (hash-ref edited 'savedPlaylists)) 'count) 1)
|
|
(check-equal? (hash-ref (car (hash-ref edited 'savedPlaylists)) 'duration) 120))
|
|
(player-command! value "tab-delete" (hasheq 'index 0))
|
|
(let ((opened (player-command! value "playlist-open" (hasheq 'id id))))
|
|
(check-equal? (length (hash-ref opened 'tabs)) 2)
|
|
(check-equal? (hash-ref opened 'currentTab) 1)
|
|
(check-equal? (map (λ (track) (hash-ref track 'title)) (hash-ref opened 'tracks)) '("Two")))
|
|
(player-agent-register! value (hasheq 'appId agent-id 'name "Test agent"))
|
|
(player-command! value "renderer" (hasheq 'id (agent-renderer-id agent-id)))
|
|
(let ((playing (player-command! value "playlist-play" (hasheq 'id id))))
|
|
(check-equal? (hash-ref playing 'currentIndex) 0)
|
|
(check-equal? (length (hash-ref playing 'tabs)) 2)
|
|
(check-equal?
|
|
(hash-ref (hash-ref (player-agent-poll! value (hasheq 'appId agent-id)) 'command) 'action)
|
|
"play"))
|
|
(player-command! value "tab-delete" (hasheq 'index 1))
|
|
(check-equal? (hash-ref (player-state->jsexpr value #:username "other") 'savedPlaylists) '())
|
|
(check-exn exn:fail?
|
|
(λ () (player-command! value "playlist-open" (hasheq 'id id) #:username "other")))
|
|
(player-close! value)
|
|
(let ((restored (make-player libraries #:playlist-keystore store-file #:local-output? #f)))
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(let ((state (player-state->jsexpr restored)))
|
|
(check-equal? (length (hash-ref state 'tabs)) 1)
|
|
(check-equal? (hash-ref (car (hash-ref state 'savedPlaylists)) 'id) id))
|
|
(player-command! restored "playlist-open" (hasheq 'id id))
|
|
(let ((renamed (player-command! restored "tab-rename" (hasheq 'index 1 'name "Restored"))))
|
|
(check-equal? (hash-ref (car (hash-ref renamed 'savedPlaylists)) 'name) "Restored")
|
|
(check-equal? (map (λ (track) (hash-ref track 'title)) (hash-ref renamed 'tracks)) '("Two")))
|
|
(player-command! restored "tab-delete" (hasheq 'index 0))
|
|
(let ((closed (player-command! restored "tab-delete" (hasheq 'index 0))))
|
|
(check-equal? (length (hash-ref closed 'tabs)) 1)
|
|
(check-false (hash-ref (car (hash-ref closed 'tabs)) 'saved))
|
|
(check-equal? (hash-ref closed 'tracks) '())
|
|
(check-equal? (hash-ref (car (hash-ref closed 'savedPlaylists)) 'id) id)))
|
|
(λ () (player-close! restored))))))
|
|
(λ () (player-close! value)))))
|
|
(λ () (delete-directory/files root)))))
|
|
|
|
(define root
|
|
(make-temporary-file "rkt-web-player-~a" 'directory))
|
|
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(make-directory (build-path root "Album"))
|
|
(let* ((libraries (make-music-libraries (list root)))
|
|
(playlist-keystore (build-path root "playlists.keystore"))
|
|
(test-agent-id (make-string 64 #\a))
|
|
(example-player
|
|
(make-player libraries
|
|
#:playlist-keystore playlist-keystore
|
|
#:allowed-agent-ids (list test-agent-id)))
|
|
(initial-state
|
|
(player-state->jsexpr example-player)))
|
|
(check-equal? (hash-ref initial-state 'state) "stopped")
|
|
(check-equal? (hash-ref initial-state 'rendererId) "local")
|
|
(check-equal? (length (hash-ref initial-state 'libraries)) 1)
|
|
(check-equal?
|
|
(length (hash-ref (hash-ref initial-state 'browser) 'entries))
|
|
1)
|
|
(check-equal? (length (hash-ref initial-state 'tracks)) 0)
|
|
|
|
(define browsed-state
|
|
(player-command!
|
|
example-player
|
|
"browse"
|
|
(hasheq 'index 0)))
|
|
|
|
(check-equal?
|
|
(hash-ref (hash-ref browsed-state 'browser) 'path)
|
|
'("Album"))
|
|
(check-true
|
|
(hash-ref (hash-ref browsed-state 'browser) 'canGoUp))
|
|
|
|
(define root-state
|
|
(player-command! example-player "up" (hasheq)))
|
|
|
|
(check-equal?
|
|
(hash-ref (hash-ref root-state 'browser) 'path)
|
|
'())
|
|
|
|
(define repeat-state
|
|
(player-command!
|
|
example-player
|
|
"repeat"
|
|
(hasheq 'mode "all")))
|
|
|
|
(check-equal? (hash-ref repeat-state 'repeat) "all")
|
|
|
|
(define tab-state
|
|
(player-command!
|
|
example-player
|
|
"tab-add"
|
|
(hasheq)))
|
|
|
|
(check-equal? (length (hash-ref tab-state 'tabs)) 2)
|
|
(check-equal? (hash-ref tab-state 'currentTab) 1)
|
|
|
|
(define renamed-state
|
|
(player-command!
|
|
example-player
|
|
"tab-rename"
|
|
(hasheq 'index 1 'name "Favorieten")))
|
|
|
|
(check-equal?
|
|
(hash-ref (list-ref (hash-ref renamed-state 'tabs) 1) 'name)
|
|
"Favorieten")
|
|
|
|
(define deleted-state
|
|
(player-command!
|
|
example-player
|
|
"tab-delete"
|
|
(hasheq 'index 1)))
|
|
|
|
(check-equal? (length (hash-ref deleted-state 'tabs)) 1)
|
|
|
|
(define registration
|
|
(player-agent-register!
|
|
example-player
|
|
(hasheq 'appId test-agent-id
|
|
'name "Test laptop")))
|
|
|
|
(check-equal? (hash-ref registration 'name) "Test laptop")
|
|
(check-exn
|
|
exn:fail:agent-denied?
|
|
(λ ()
|
|
(player-agent-register!
|
|
example-player
|
|
(hasheq 'appId (make-string 64 #\b)
|
|
'name "Unknown laptop"))))
|
|
|
|
(define agent-renderer-state
|
|
(player-command!
|
|
example-player
|
|
"renderer"
|
|
(hasheq 'id (agent-renderer-id test-agent-id))))
|
|
|
|
(check-equal?
|
|
(hash-ref agent-renderer-state 'rendererId)
|
|
(agent-renderer-id test-agent-id))
|
|
|
|
(player-command!
|
|
example-player
|
|
"volume"
|
|
(hasheq 'value 25))
|
|
|
|
(define first-poll
|
|
(player-agent-poll!
|
|
example-player
|
|
(hasheq 'appId test-agent-id
|
|
'ack 0
|
|
'endedCounter 0
|
|
'state
|
|
(hasheq 'state "stopped"
|
|
'position 0
|
|
'volume 25))))
|
|
|
|
(check-equal?
|
|
(hash-ref (hash-ref first-poll 'command) 'action)
|
|
"volume")
|
|
|
|
(define first-command-id
|
|
(hash-ref (hash-ref first-poll 'command) 'id))
|
|
|
|
(define acknowledged-poll
|
|
(player-agent-poll!
|
|
example-player
|
|
(hasheq 'appId test-agent-id
|
|
'ack first-command-id
|
|
'endedCounter 0
|
|
'state
|
|
(hasheq 'state "stopped"
|
|
'position 0
|
|
'volume 25))))
|
|
|
|
(check-eq? (hash-ref acknowledged-poll 'command) 'null)
|
|
|
|
(check-equal?
|
|
(hash-ref
|
|
(player-agent-register!
|
|
example-player
|
|
(hasheq 'appId test-agent-id
|
|
'name "Office laptop"))
|
|
'name)
|
|
"Office laptop")
|
|
(check-equal?
|
|
(renderer-name
|
|
(findf
|
|
(λ (item)
|
|
(string=? (renderer-id item)
|
|
(agent-renderer-id test-agent-id)))
|
|
(player-renderers example-player)))
|
|
"Office laptop")
|
|
|
|
(define first-file (build-path root "Album" "01.flac"))
|
|
(define second-file (build-path root "Album" "02.flac"))
|
|
(call-with-output-file first-file void #:exists 'truncate/replace)
|
|
(call-with-output-file second-file void #:exists 'truncate/replace)
|
|
(set-player-tracks!
|
|
example-player
|
|
(list (track first-file "First" "Artist" "Album" 60 "audio/flac")
|
|
(track second-file "Second" "Artist" "Album" 60 "audio/flac")))
|
|
;; Exercise persistence through ordinary playlist mutations while
|
|
;; restoring the original order for the playback-agent assertions.
|
|
(player-command!
|
|
example-player "track-move" (hasheq 'from 0 'to 1))
|
|
(player-command!
|
|
example-player "track-move" (hasheq 'from 1 'to 0))
|
|
|
|
(player-command! example-player "play" (hasheq 'index 0))
|
|
(define play-poll
|
|
(player-agent-poll!
|
|
example-player
|
|
(hasheq 'appId test-agent-id
|
|
'ack first-command-id
|
|
'endedCounter 0
|
|
'state (hasheq 'state "starting" 'position 0))))
|
|
(define play-command (hash-ref play-poll 'command))
|
|
(check-equal? (hash-ref play-command 'action) "play")
|
|
(check-equal?
|
|
(hash-ref (hash-ref play-command 'data) 'trackNumber)
|
|
1)
|
|
(check-equal?
|
|
(player-agent-media
|
|
example-player
|
|
test-agent-id
|
|
(hash-ref (hash-ref play-command 'data) 'mediaToken))
|
|
first-file)
|
|
|
|
(define prefetch-poll
|
|
(player-agent-poll!
|
|
example-player
|
|
(hasheq 'appId test-agent-id
|
|
'ack (hash-ref play-command 'id)
|
|
'endedCounter 0
|
|
'state (hasheq 'state "playing" 'position 1))))
|
|
(define prefetch-command (hash-ref prefetch-poll 'command))
|
|
(check-equal? (hash-ref prefetch-command 'action) "prefetch")
|
|
(check-equal?
|
|
(hash-ref (hash-ref prefetch-command 'data) 'trackNumber)
|
|
2)
|
|
(check-equal?
|
|
(player-agent-media
|
|
example-player
|
|
test-agent-id
|
|
(hash-ref (hash-ref prefetch-command 'data) 'mediaToken))
|
|
second-file)
|
|
|
|
(check-exn exn:fail?
|
|
(λ ()
|
|
(player-command!
|
|
example-player
|
|
"unknown"
|
|
(hasheq))))
|
|
|
|
(define hans-tabs
|
|
(player-command!
|
|
example-player
|
|
"tab-add"
|
|
(hasheq)
|
|
#:username "hans"))
|
|
(check-equal? (length (hash-ref hans-tabs 'tabs)) 2)
|
|
(player-command!
|
|
example-player
|
|
"tab-rename"
|
|
(hasheq 'index 1 'name "Hans favorieten")
|
|
#:username "hans")
|
|
(define anonymous-after-hans
|
|
(player-state->jsexpr example-player #:username "anonymous"))
|
|
(check-equal? (length (hash-ref anonymous-after-hans 'tabs)) 1)
|
|
(check-equal? (length (hash-ref anonymous-after-hans 'tracks)) 2)
|
|
(player-user-language! example-player "nl")
|
|
(player-user-language!
|
|
example-player "de" #:username "hans")
|
|
(check-equal? (player-user-language example-player) "nl")
|
|
(check-equal?
|
|
(player-user-language example-player #:username "hans")
|
|
"de")
|
|
(player-close! example-player)
|
|
|
|
(define restored-player
|
|
(make-player libraries #:playlist-keystore playlist-keystore))
|
|
(define restored-state (player-state->jsexpr restored-player))
|
|
(check-equal? (length (hash-ref restored-state 'tabs)) 1)
|
|
(check-equal? (length (hash-ref restored-state 'tracks)) 2)
|
|
(check-equal?
|
|
(hash-ref (car (hash-ref restored-state 'tracks)) 'source)
|
|
"01.flac")
|
|
(define restored-hans
|
|
(player-state->jsexpr restored-player #:username "hans"))
|
|
(check-equal? (length (hash-ref restored-hans 'tabs)) 2)
|
|
(check-equal?
|
|
(hash-ref (second (hash-ref restored-hans 'tabs)) 'name)
|
|
"Hans favorieten")
|
|
(check-equal? (player-user-language restored-player) "nl")
|
|
(check-equal?
|
|
(player-user-language restored-player #:username "hans")
|
|
"de")
|
|
(player-close! restored-player)
|
|
|
|
(define no-local-player
|
|
(make-player libraries
|
|
#:allowed-agent-ids (list test-agent-id)
|
|
#:local-output? #f))
|
|
(define no-local-state (player-state->jsexpr no-local-player))
|
|
(check-equal? (hash-ref no-local-state 'renderers) '())
|
|
(check-equal? (hash-ref no-local-state 'rendererId) 'null)
|
|
(player-agent-register!
|
|
no-local-player
|
|
(hasheq 'appId test-agent-id 'name "Test agent"))
|
|
(define agent-only-state (player-state->jsexpr no-local-player))
|
|
(check-equal? (length (hash-ref agent-only-state 'renderers)) 1)
|
|
(check-equal? (hash-ref agent-only-state 'rendererId)
|
|
(string-append "agent:" test-agent-id))
|
|
(player-close! no-local-player)
|
|
|
|
;; Two users can drive different outputs concurrently. Selecting an
|
|
;; occupied output transfers it and stops only its previous owner.
|
|
(define second-agent-id (make-string 64 #\b))
|
|
(define multi-user-player
|
|
(make-player
|
|
libraries
|
|
#:allowed-agent-ids (list test-agent-id second-agent-id)
|
|
#:local-output? #f))
|
|
(player-agent-register!
|
|
multi-user-player
|
|
(hasheq 'appId test-agent-id 'name "First room"))
|
|
(player-agent-register!
|
|
multi-user-player
|
|
(hasheq 'appId second-agent-id 'name "Second room"))
|
|
(define anonymous-session
|
|
(playback-session-for! multi-user-player "anonymous"))
|
|
(define hans-session
|
|
(playback-session-for! multi-user-player "hans"))
|
|
(activate-playlist-user!
|
|
multi-user-player "anonymous" anonymous-session)
|
|
(append-tracks!
|
|
multi-user-player anonymous-session
|
|
(list (track first-file "First" "Artist" "Album" 60
|
|
"audio/flac")))
|
|
(activate-playlist-user! multi-user-player "hans" hans-session)
|
|
(append-tracks!
|
|
multi-user-player hans-session
|
|
(list (track second-file "Second" "Artist" "Album" 60
|
|
"audio/flac")))
|
|
(player-command!
|
|
multi-user-player
|
|
"renderer"
|
|
(hasheq 'id (agent-renderer-id test-agent-id)))
|
|
(player-command!
|
|
multi-user-player
|
|
"renderer"
|
|
(hasheq 'id (agent-renderer-id second-agent-id))
|
|
#:username "hans")
|
|
(player-command! multi-user-player "play" (hasheq 'index 0))
|
|
(player-command!
|
|
multi-user-player "play" (hasheq 'index 0) #:username "hans")
|
|
(check-equal? (playback-session-state anonymous-session) 'starting)
|
|
(check-equal? (playback-session-state hans-session) 'starting)
|
|
(check-not-eq? (playback-session-backend anonymous-session)
|
|
(playback-session-backend hans-session))
|
|
|
|
(player-command!
|
|
multi-user-player
|
|
"renderer"
|
|
(hasheq 'id (agent-renderer-id test-agent-id))
|
|
#:username "hans")
|
|
(check-equal? (playback-session-state anonymous-session) 'stopped)
|
|
(check-false (playback-session-backend anonymous-session))
|
|
(check-equal?
|
|
(playback-session-error anonymous-session)
|
|
"Het afspeelpunt is door een andere gebruiker overgenomen")
|
|
(check-eq?
|
|
(hash-ref (player-renderer-owners multi-user-player)
|
|
(agent-renderer-id test-agent-id))
|
|
hans-session)
|
|
(player-close! multi-user-player)))
|
|
(λ ()
|
|
(delete-directory/files root))))
|