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

ini file support and cover art

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-27 13:33:34 +02:00
parent 744a2815f1
commit 84891adb89
13 changed files with 422 additions and 79 deletions
Download Patch File Download Diff File Expand all files Collapse all files
private/library.rkt
+98 -13
View File
@@ -10,9 +10,11 @@
(provide (struct-out music-library)
(struct-out browser-entry)
(struct-out track)
(struct-out artwork)
make-music-libraries
browse-library
browser-entry->tracks)
browser-entry->tracks
track-artwork)
(struct music-library
(id name root)
@@ -26,6 +28,10 @@
(file title artist album duration mime-type)
#:transparent)
(struct artwork
(mime-type data)
#:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -33,6 +39,11 @@
(define supported-extensions
(audio-supported-extensions))
(define cover-file-names
'("cover.jpg" "cover.jpeg" "cover.png"
"folder.jpg" "folder.jpeg" "folder.png"
"front.jpg" "front.jpeg" "front.png"))
(define (audio-file? file)
(let ((extension (path-get-extension file)))
(and extension
@@ -128,20 +139,38 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Turn configured directory paths into music libraries.
; pre : Every value is a path-string naming an existing directory.
; pre : Every value is a path or a (display-name path) list.
; post : No directory contents or audio metadata have been read.
; result : Libraries in configuration order, without duplicate roots.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-music-libraries paths)
(define (make-music-libraries specifications)
(define (specification-values specification)
(if (and (list? specification)
(= (length specification) 2)
(string? (car specification))
(path-string? (cadr specification)))
(values (string-trim (car specification))
(cadr specification))
(if (path-string? specification)
(values #f specification)
(raise-argument-error
'make-music-libraries
"(or/c path-string? (list/c string? path-string?))"
specification))))
(let ((roots
(remove-duplicates
(map (λ (path)
(normal-case-path
(path->complete-path path)))
paths)
equal?)))
(for/list ((root (in-list roots))
(for/list ((specification (in-list specifications)))
(let-values (((name path)
(specification-values specification)))
(list name
(normal-case-path
(path->complete-path path)))))
(lambda (first second)
(equal? (cadr first) (cadr second))))))
(for/list ((named-root (in-list roots))
(index (in-naturals)))
(define configured-name (car named-root))
(define root (cadr named-root))
(unless (directory-exists? root)
(raise-arguments-error
'make-music-libraries
@@ -150,11 +179,56 @@
(let ((name (file-name-from-path root)))
(music-library
(format "library-~a" index)
(if name
(path->string name)
(path->string root))
(if (and configured-name
(not (string=? configured-name "")))
configured-name
(if name
(path->string name)
(path->string root)))
root)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read the artwork associated with a track.
; pre : Item names a local audio file.
; post : The audio file and optional neighbouring image remain unchanged.
; result : Embedded artwork, a conventional folder cover, or #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (track-artwork item)
(define embedded
(with-handlers ((exn:fail? (λ (_) #f)))
(call-with-id3-tags
(track-file item)
(λ (tags)
(let ((picture (and (tags-valid? tags)
(tags-picture tags))))
(and picture
(artwork (let ((mime (id3-picture-mimetype picture)))
(if (and (string? mime)
(not (string=? mime "")))
mime
"application/octet-stream"))
(id3-picture-bytes picture))))))))
(or embedded
(with-handlers ((exn:fail? (λ (_) #f)))
(let* ((directory (or (path-only (track-file item))
(current-directory)))
(cover
(findf
(λ (candidate)
(let ((name (file-name-from-path candidate)))
(and name
(file-exists? candidate)
(member (path->string name)
cover-file-names
string-ci=?))))
(directory-list directory #:build? #t))))
(and cover
(let ((mime (mimetype-for-ext cover)))
(artwork (if (string? mime)
mime
"application/octet-stream")
(file->bytes cover))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : List the immediate folders and supported audio files in a library.
; pre : Relative-path was produced by a previous browse result.
@@ -217,6 +291,17 @@
(check-equal? (browser-entry-name (car entries)) "Album")
(check-eq? (browser-entry-kind (car entries)) 'container)
(check-equal? (browser-entry-name (cadr entries)) "track.mp3")
(check-eq? (browser-entry-kind (cadr entries)) 'track)))
(check-eq? (browser-entry-kind (cadr entries)) 'track)
(check-equal?
(music-library-name
(car (make-music-libraries
(list (list "Luisterkamer" root)))))
"Luisterkamer")
(check-equal?
(artwork-mime-type
(track-artwork
(track (build-path root "track.mp3")
"Track" "" "" #f "audio/mpeg")))
"image/jpeg")))
(λ ()
(delete-directory/files root))))
private/player-agent-gui.rkt
+37 -3
View File
@@ -18,6 +18,9 @@
(provide run-player-agent-gui)
(struct exn:fail:agent-denied exn:fail ()
#:transparent)
(define (input-field label init-val panel)
(let ((tf (new text-field%
@@ -91,8 +94,14 @@
(let ((response (read-json input)))
(when (and (hash? response)
(string? (hash-ref response 'error #f)))
(error 'player-agent
(hash-ref response 'error)))
(if (equal? (hash-ref response 'code #f)
"agent-not-authorized")
(raise
(exn:fail:agent-denied
(hash-ref response 'error)
(current-continuation-marks)))
(error 'player-agent
(hash-ref response 'error))))
response))
(λ ()
(close-input-port input)))))
@@ -122,6 +131,7 @@
(define command-worker #f)
(define executing-command-id 0)
(define running? #f)
(define authorization-notified? #f)
(define audio #f)
(define temporary-media #f)
(define current-media-key #f)
@@ -509,7 +519,30 @@
(define (poll-loop)
(with-handlers
((exn:fail?
((exn:fail:agent-denied?
(λ (exception)
(define message
(string-append
"Deze playback agent is niet toegelaten door de server. "
"Voeg het volgende applicatie-ID toe aan [playback-agents] "
"in de server-INI:\n\n"
app-id))
(warn-player-agent "Agent authorization refused: ~a"
(exn-message exception))
(set-agent-error! message)
(show-status! "Niet geautoriseerd — applicatie-ID staat niet in de server-INI")
(unless authorization-notified?
(set! authorization-notified? #t)
(queue-callback
(λ ()
(message-box "Playback agent niet toegestaan"
message
frame
'(ok stop)))))
(when running?
(sleep 3)
(poll-loop))))
(exn:fail?
(λ (exception)
(warn-player-agent "Connection cycle failed: ~a"
(exn-message exception))
@@ -588,6 +621,7 @@
(define (reconnect!)
(stop-worker!)
(set! authorization-notified? #f)
(set! server-url (string-trim (send server-field get-value)))
(let ((new-name (string-trim (send name-field get-value))))
(set! assigned-name
private/player.rkt
+81 -15
View File
@@ -19,6 +19,8 @@
player-agent-register!
player-agent-poll!
player-agent-media
player-track-artwork
exn:fail:agent-denied?
player-close!)
(sl-def-log web-player)
@@ -38,12 +40,16 @@
[ended-counter #:mutable])
#:transparent)
(struct exn:fail:agent-denied exn:fail ()
#:transparent)
(struct playlist-tab
(id [name #:mutable] [tracks #:mutable])
#:transparent)
(struct player
(libraries
allowed-agent-ids
[agents #:mutable]
[current-library-id #:mutable]
[browser-path #:mutable]
@@ -103,6 +109,25 @@
(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)))
@@ -736,6 +761,7 @@
'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)))))
@@ -1011,11 +1037,21 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a player for lazily browsed music libraries.
; pre : Libraries is a list of music-library values; DLNA port is positive.
; pre : Libraries are valid; allowed agent IDs are 256-bit hex strings.
; post : Only the selected root directory has been listed; no backend exists.
; result : A player that initially selects local playback.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-player libraries #:dlna-port [dlna-port 8734])
(define (make-player libraries
#:allowed-agent-ids [allowed-agent-ids '()]
#:dlna-port [dlna-port 8734])
(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)))
(let* ((library (and (pair? libraries) (car libraries)))
(browser-entries
(if library
@@ -1023,6 +1059,7 @@
'()))
(tab (playlist-tab "default" "Default" '())))
(player libraries
(remove-duplicates normalized-agent-ids string=?)
'()
(and library (music-library-id library))
'()
@@ -1184,12 +1221,13 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Register or refresh one polling playback agent.
; pre : Data contains a 256-bit hexadecimal application id.
; 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* ((app-id (json-string data 'appId #f))
(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)
@@ -1198,11 +1236,12 @@
(if (string=? suggested-name "")
"RKT playback agent"
suggested-name)))
(unless (valid-agent-id? app-id)
(unless app-id
(raise-arguments-error
'player-agent-register!
"appId must contain exactly 64 hexadecimal characters"
"appId" app-id))
"appId" supplied-app-id))
(require-authorized-agent! value app-id)
(with-state-lock
value
(λ ()
@@ -1247,13 +1286,15 @@
; result : Poll response containing the current agent name and optional command.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (player-agent-poll! value data)
(let ((app-id (json-string data 'appId #f))
(let* ((supplied-app-id (json-string data 'appId #f))
(app-id (normal-agent-id supplied-app-id))
(name (json-string data 'name #f)))
(unless (valid-agent-id? app-id)
(unless app-id
(raise-arguments-error
'player-agent-poll!
"appId must contain exactly 64 hexadecimal characters"
"appId" app-id))
"appId" supplied-app-id))
(require-authorized-agent! value app-id)
(call-with-semaphore
(player-command-lock value)
(λ ()
@@ -1324,12 +1365,30 @@
(with-state-lock
value
(λ ()
(let ((agent (and (valid-agent-id? app-id)
(agent-by-id value app-id))))
(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)
(let ((item
(with-state-lock
value
(λ ()
(findf (λ (candidate)
(string=? (track-cache-key candidate) artwork-id))
(player-tracks value))))))
(and item (track-artwork item))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Stop playback and release all player resources.
; pre : Value was created with make-player.
@@ -1358,7 +1417,10 @@
(λ ()
(make-directory (build-path root "Album"))
(let* ((libraries (make-music-libraries (list root)))
(example-player (make-player libraries))
(test-agent-id (make-string 64 #\a))
(example-player
(make-player libraries
#:allowed-agent-ids (list test-agent-id)))
(initial-state
(player-state->jsexpr example-player)))
(check-equal? (hash-ref initial-state 'state) "stopped")
@@ -1423,9 +1485,6 @@
(check-equal? (length (hash-ref deleted-state 'tabs)) 1)
(define test-agent-id
(make-string 64 #\a))
(define registration
(player-agent-register!
example-player
@@ -1433,6 +1492,13 @@
'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!
private/server.rkt
+31 -2
View File
@@ -10,6 +10,7 @@
web-server/http
web-server/http/json
web-server/servlet-env
"library.rkt"
"player.rkt")
(provide serve-player)
@@ -33,6 +34,12 @@
(hasheq 'error (exn-message exception))
#:code 400))
(define (agent-error-response exception)
(json-response
(hasheq 'error (exn-message exception)
'code "agent-not-authorized")
#:code 403))
(define (request-jsexpr request)
(let ((body (request-post-data/raw request)))
(if (and body (positive? (bytes-length body)))
@@ -57,7 +64,8 @@
(define (agent-register-handler request)
(with-handlers
((exn:fail? error-response))
((exn:fail:agent-denied? agent-error-response)
(exn:fail? error-response))
(json-response
(player-agent-register!
current-player
@@ -65,7 +73,8 @@
(define (agent-poll-handler request)
(with-handlers
((exn:fail? error-response))
((exn:fail:agent-denied? agent-error-response)
(exn:fail? error-response))
(json-response
(player-agent-poll!
current-player
@@ -95,6 +104,25 @@
(hasheq 'error "media token is invalid or expired")
#:code 404))))
(define (artwork-handler _request artwork-id)
(let ((value (player-track-artwork current-player artwork-id)))
(if value
(response/output
(λ (output)
(write-bytes (artwork-data value) output))
#:mime-type
(string->bytes/utf-8 (artwork-mime-type value))
#:headers
(list
(header #"Content-Length"
(string->bytes/utf-8
(number->string
(bytes-length (artwork-data value)))))
(header #"Cache-Control" #"private, max-age=3600")))
(json-response
(hasheq 'error "track artwork is unavailable")
#:code 404))))
(define-values (dispatch _url)
(dispatch-rules
[("api" "state") #:method "get" state-handler]
@@ -104,6 +132,7 @@
[("api" "agent" "media" (string-arg) (string-arg))
#:method "get"
agent-media-handler]
[("api" "artwork" (string-arg)) #:method "get" artwork-handler]
[("api" "command" (string-arg))
#:method "post"
command-handler]))