hans/rkt-web-player
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ok

Browse Source
This commit is contained in:
Hans Dijkema
2026-09-08 15:20:27 +02:00
parent 4b9e6c5651
commit 2eb9a9590e
15 changed files with 1023 additions and 127 deletions
Download Patch File Download Diff File Expand all files Collapse all files
private/player.rkt
+301 -59
View File
@@ -50,11 +50,13 @@
#:transparent)
(struct playlist-tab
(id [name #:mutable] [tracks #:mutable])
(id [name #:mutable] [tracks #:mutable] [snapshot #:auto #:mutable])
#:auto-value #f
#:transparent)
(struct playlist-context
([tabs #:mutable] [current-index #:mutable])
([tabs #:mutable] [current-index #:mutable] [saved #:auto #:mutable])
#:auto-value '()
#:transparent)
(struct playback-session
@@ -260,36 +262,45 @@
(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)
(set-playlist-tab-tracks!
(current-tab value)
(player-tracks 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")))
(define (new-playlist-context value username)
(define stored
(load-user-playlists (player-playlist-store value)
username
(player-libraries value)))
(playlist-context
(if (pair? stored)
(for/list ((tab (in-list stored)))
(playlist-tab (persisted-tab-id tab)
(persisted-tab-name tab)
(persisted-tab-tracks tab)))
(list (playlist-tab (uuid-string) "Default" '())))
0))
;;; 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
(λ () (new-playlist-context value normalized))))
(λ () (restore-playlist-context (player-playlist-store value)
normalized (player-libraries value)))))
(define (context-tracks context)
(playlist-tab-tracks
@@ -361,7 +372,12 @@
(for/list ((tab (in-list (player-tabs value))))
(persisted-tab (playlist-tab-id tab)
(playlist-tab-name tab)
(playlist-tab-tracks 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
@@ -927,25 +943,28 @@
trimmed)
(persist-playlists! value)))))
;;; Close a tab, retaining saved playlists in the user's library.
(define (delete-tab! value session index)
(when (= (length (player-tabs value)) 1)
(raise-arguments-error
'player-command!
"the last playlist tab cannot be removed"))
(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* ((tabs
(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))))
@@ -958,6 +977,44 @@
(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)
@@ -984,14 +1041,29 @@
'name (browser-entry-name entry)
'kind (symbol->string (browser-entry-kind entry))))
;;; Include the sum of known track durations in each tab's browser summary.
(define (tab->jsexpr tab index)
(hasheq 'index index
'id (playlist-tab-id tab)
'name (playlist-tab-name tab)
'count (length (playlist-tab-tracks tab))
'duration (apply + (map (λ (item) (or (track-duration item) 0))
(playlist-tab-tracks tab)))))
;;; 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)))
@@ -1121,7 +1193,12 @@
(rename-tab! value index
(or (json-string data 'name #f) "")))
((string=? command "tab-delete")
(delete-tab! value session index)))))
(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
@@ -1131,7 +1208,7 @@
((member command '("track-remove" "track-move"
"playlist-clear" "tab-add"
"tab-select" "tab-rename"
"tab-delete"))
"tab-delete" "playlist-save" "playlist-open" "playlist-play"))
(perform-playlist-command! value session command data))
((string=? command "play")
(play-index!
@@ -1278,23 +1355,15 @@
app-id))
(string-downcase app-id)))
(define store (open-playlist-store playlist-keystore))
(define stored-tabs
(load-user-playlists store "anonymous" libraries))
(let* ((library (and (pair? libraries) (car libraries)))
(browser-entries
(if library
(browse-library library '())
'()))
(tabs
(if (pair? stored-tabs)
(for/list ((tab (in-list stored-tabs)))
(playlist-tab (persisted-tab-id tab)
(persisted-tab-name tab)
(persisted-tab-tracks tab)))
(list (playlist-tab (uuid-string) "Default" '()))))
(initial-context (restore-playlist-context store "anonymous" libraries))
(tabs (playlist-context-tabs initial-context))
(selected-index 0)
(contexts (make-hash))
(initial-context (playlist-context tabs selected-index)))
(contexts (make-hash)))
(hash-set! contexts "anonymous" initial-context)
(define value
(player libraries
@@ -1324,12 +1393,17 @@
value))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Return the complete browser-visible player state.
; 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.
; 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"])
(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)
@@ -1340,7 +1414,7 @@
(define context (playlist-context-for! value normalized))
(define tabs (playlist-context-tabs context))
(define tab-index (playlist-context-current-index context))
(define tracks (playlist-tab-tracks (list-ref tabs tab-index)))
(define snapshot (tab-snapshot (list-ref tabs tab-index)))
(with-state-lock
value
(λ ()
@@ -1366,12 +1440,17 @@
'tabs
(for/list ((tab (in-list tabs))
(index (in-naturals)))
(tab->jsexpr tab index))
(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
(for/list ((item (in-list tracks))
(index (in-naturals)))
(track->jsexpr item index))
(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)
@@ -1401,14 +1480,16 @@
; 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.
; 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" "play"))
"tab-delete" "playlist-save" "playlist-open" "playlist-play" "play"))
(define (player-command! value command data #:username [username "anonymous"])
(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)
@@ -1426,7 +1507,8 @@
(when (member command playlist-context-commands)
(activate-playlist-user! value normalized session))
(perform-command! value session command data))))
(player-state->jsexpr value #:username normalized))
(player-state->jsexpr value #:username normalized
#:playlist-version playlist-version))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Discover UPnP renderers and logical Sonos groups asynchronously.
@@ -1739,16 +1821,176 @@
(λ ()
(set-player-closed?! value #t)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module player.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require rackunit
(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))