Compare commits

..

7 Commits

Author SHA1 Message Date
hans 2eb9a9590e ok 2026-09-08 15:20:27 +02:00
hans 4b9e6c5651 adding playing time for a playlist 2026-09-08 10:18:36 +02:00
hans 365a7b8317 better descriptions 2026-09-03 23:29:16 +02:00
hans a5a53b7efc refactoring 2026-09-01 09:31:49 +02:00
hans b3a5a0b345 refactoring volgens skill 2026-08-29 22:25:06 +02:00
hans 09121df0d7 Merge branch 'main' of https://git.dijkewijk.nl/hans/rkt-web-player 2026-08-29 21:33:56 +02:00
hans 19e66fbb18 Skill updated 2026-08-29 21:33:44 +02:00
35 changed files with 4527 additions and 2319 deletions
+5
View File
@@ -25,3 +25,8 @@ rkt-web-player.ini
# Runtime playlist keystore # Runtime playlist keystore
data/*.keystore* data/*.keystore*
/.scribble-build
# Logging
*.log
*.log.*
+47 -17
View File
@@ -47,9 +47,9 @@ flowchart TB
Audio[racket-audio<br/>local backend] Audio[racket-audio<br/>local backend]
Discovery[racket-upnp + racket-sonos<br/>device discovery] Discovery[racket-upnp + racket-sonos<br/>device discovery]
DLNA[racket-audio-dlna<br/>transport, seeking and media publication] DLNA[racket-audio-dlna<br/>transport, seeking and media publication]
AgentGUI[private/player-agent-gui.rkt<br/>GUI adapter] AgentGUI[private-player-agent/player-agent-gui.rkt<br/>GUI adapter]
AgentCLI[player-agent-cli.rkt<br/>CLI adapter] AgentCLI[player-agent-cli.rkt<br/>CLI adapter]
AgentCore[private/player-agent-core.rkt<br/>polling and audio runtime] AgentCore[private-player-agent/player-agent-core.rkt<br/>polling and audio runtime]
Main --> Server Main --> Server
Main --> Player Main --> Player
@@ -139,7 +139,14 @@ volume, and repeat mode.
Selecting, deleting, or creating a tab stops playback. Tracks are de-duplicated Selecting, deleting, or creating a tab stops playback. Tracks are de-duplicated
by normalized source path when they are appended. Every playlist mutation is by normalized source path when they are appended. Every playlist mutation is
written in one `keystore` transaction. `playlists-for-<username>` contains the written in one `keystore` transaction. `playlists-for-<username>` contains the
ordered playlist GUIDs; each GUID key contains that playlist's name and tracks. ordered open playlist GUIDs; `saved-playlists-for-<username>` contains the saved
library playlist GUIDs. Each GUID key contains one playlist's name and tracks.
Both indexes are persisted atomically; a value is deleted only when neither
index refers to it. Closing a saved tab retains its library entry.
`restore-playlist-context` reuses the same in-memory object for a saved playlist
and its open tab, so track edits and renaming update both views. Old stores
without a saved index restore their original tabs without automatically saving
them in the library.
Loading validates every stored track independently against all configured Loading validates every stored track independently against all configured
library roots, so one playlist can safely combine multiple libraries. library roots, so one playlist can safely combine multiple libraries.
`language-for-<username>` stores the user's selected interface language in the `language-for-<username>` stores the user's selected interface language in the
@@ -224,7 +231,7 @@ serves static assets from [`public/`](public/) and exposes these API endpoints:
| Method | Route | Responsibility | | Method | Route | Responsibility |
| --- | --- | --- | | --- | --- | --- |
| `GET` | `/api/state` | Return the complete current state; also refresh network-renderer information. | | `GET` | `/api/state` | Return current state, omitting unchanged tracks when `playlistVersion` matches; also refresh network-renderer information. |
| `POST` | `/api/discover` | Start asynchronous discovery and return the current state. | | `POST` | `/api/discover` | Start asynchronous discovery and return the current state. |
| `POST` | `/api/command/:command` | Execute a command with its JSON request body and return the updated state. | | `POST` | `/api/command/:command` | Execute a command with its JSON request body and return the updated state. |
| `GET` | `/api/preferences` | Return the current user's durable UI preferences. | | `GET` | `/api/preferences` | Return the current user's durable UI preferences. |
@@ -241,20 +248,40 @@ header. Command failures are returned as HTTP 400 JSON responses with an
[`public/app.js`](public/app.js) implements a framework-free client. It: [`public/app.js`](public/app.js) implements a framework-free client. It:
- fetches a full state snapshot once per second; - polls status once per second, receiving tracks only when the playlist version changes;
- temporarily suppresses polling while a browser-initiated command is active; - temporarily suppresses polling while a browser-initiated command is active;
- immediately renders the state returned by successful commands; - immediately renders the state returned by successful commands;
- renders library navigation, playlists, tabs, transport status, and output - renders library navigation, playlists, tabs, transport status, and output
selection; selection;
- implements keyboard actions and playlist drag-and-drop in the browser. - implements keyboard actions and playlist drag-and-drop in the browser.
[`public/playlist-library.js`](public/playlist-library.js) renders the library's
Folders/Playlists tabs and saved playlist summaries. `playlist-save` adds an
open tab to the library by UUID. `playlist-open` reveals its own tab, reusing an
already open tab, and `playlist-play` also starts playback. Neither action copies
tracks into an unrelated tab. Only summary metadata is sent in `savedPlaylists`.
[`public/player-state.js`](public/player-state.js) keeps the active track array
in memory and queues state, command and discovery requests. Each request sends
the last received `playlistVersion` as a query parameter. A matching response
contains `tracks: null`; the client supplies its cached tracks to the renderers.
Requests without a version still receive the full list. Queueing prevents
responses from being applied out of order.
The player caches track JSON, count, duration and an opaque version per tab.
`save-current-tab!` invalidates this snapshot when the track list changes.
Renaming a tab leaves its track snapshot intact. Versions are unique across
tabs, users and server restarts. `renderPlaylist` uses the version to decide
when to rebuild rows instead of comparing all track metadata on every poll.
[`public/translate.js`](public/translate.js) follows the key-based translation [`public/translate.js`](public/translate.js) follows the key-based translation
model used by rktplayer. It supports Dutch, English, German, French, Spanish, model used by rktplayer. It supports Dutch, English, German, French, Spanish,
Italian, Swedish, Norwegian, Finnish and Icelandic with English fallback. Italian, Swedish, Norwegian, Finnish and Icelandic with English fallback.
Browser preferences select the initial language; a Browser preferences select the initial language; a
manual selection is stored server-side per username and therefore follows the manual selection is stored server-side per username and therefore follows the
user across browsers. The native agent uses the equivalent user across browsers. The native agent uses the equivalent
[`private/translate.rkt`](private/translate.rkt) module and the operating-system [`private-player-agent/player-agent-translate.rkt`](private-player-agent/player-agent-translate.rkt)
module and the operating-system
language. language.
DOM signatures prevent rebuilding unchanged library, tab, and playlist DOM signatures prevent rebuilding unchanged library, tab, and playlist
@@ -313,9 +340,9 @@ sequenceDiagram
participant D as DLNA renderer participant D as DLNA renderer
loop Browser state polling loop Browser state polling
B->>H: GET /api/state B->>H: GET /api/state?playlistVersion=known-version
H->>P: player-state->jsexpr H->>P: player-state->jsexpr
P-->>H: Full state snapshot P-->>H: State and version; tracks only if changed
H-->>B: JSON response H-->>B: JSON response
end end
@@ -342,10 +369,11 @@ generally performed outside it, with their results committed in short locked
sections. Audio callbacks use only the short-lived state lock and update the sections. Audio callbacks use only the short-lived state lock and update the
playback session captured when their backend was created. playback session captured when their backend was created.
The server module stores the player in a module-level `current-player` variable. The server module creates one request-dispatcher closure for each `serve-player`
This matches the intended one-player-per-process deployment, but it prevents call. That closure captures its player and authentication manager and binds them
multiple independent player instances from being served safely within the same to every HTTP handler. No player or authentication state is stored in module
Racket process. variables, so independent server instances do not overwrite each other's
context within the same Racket process.
## 6. Configuration and deployment ## 6. Configuration and deployment
@@ -386,9 +414,10 @@ random application ID therefore acts as a shared bearer credential, but must
not be treated as strong authentication when transported over unencrypted HTTP. not be treated as strong authentication when transported over unencrypted HTTP.
The GUI and CLI playback agents share one headless runtime. The GUI only adapts The GUI and CLI playback agents share one headless runtime. The GUI only adapts
configuration and state to widgets. Optional tray integration is loaded configuration and state to widgets. It uses `racket-tray` directly for its
dynamically through SDL3, so CLI use and the default GUI installation do not native tray icon, symbolic Open/Exit menu and portable hide-on-minimize
acquire a mandatory SDL dependency. behaviour. The previous SDL3 adapter and its update timer are no longer part of
the process.
The configured library roots define the intended filesystem boundary. Clients The configured library roots define the intended filesystem boundary. Clients
operate on opaque indexes instead of sending paths directly. The DLNA backend operate on opaque indexes instead of sending paths directly. The DLNA backend
@@ -426,8 +455,9 @@ The main extension points are:
- **Per-user pipelines, shared outputs:** playlist and transport state are - **Per-user pipelines, shared outputs:** playlist and transport state are
isolated by username. Distinct outputs run concurrently; selecting an isolated by username. Distinct outputs run concurrently; selecting an
occupied output explicitly stops its previous owner and transfers it. occupied output explicitly stops its previous owner and transfers it.
- **Full-state snapshots:** a small and predictable client protocol, at the cost - **Versioned playlists:** cached tracks are transferred only when the selected
of repeatedly transferring all tracks and browser entries. playlist version changes. Other status fields, including browser entries,
remain part of each response.
- **One-second polling:** robust and dependency-free, but introduces periodic - **One-second polling:** robust and dependency-free, but introduces periodic
traffic and up to one second of display latency. traffic and up to one second of display latency.
- **Lazy filesystem and backend initialization:** fast startup and low idle - **Lazy filesystem and backend initialization:** fast startup and low idle
+29 -18
View File
@@ -100,13 +100,24 @@ betrouwbare next-ondersteuning krijgen na het natuurlijke trackeinde een
servergestuurde fallback. Een expliciet stopcommando start nooit de volgende servergestuurde fallback. Een expliciet stopcommando start nooit de volgende
track. track.
De bibliotheek links heeft de tabs **Mappen** en **Afspeellijsten**. Met
**Afspeellijst opslaan** boven de huidige playlist geef je de tab een naam en
bewaar je hem in de bibliotheek. **** bij een bewaarde playlist opent of
selecteert zijn eigen tab; **▶** opent die tab en speelt de playlist af.
Een playlist die al open is, krijgt geen tweede tab. De inhoud van andere
tabs blijft behouden. Wijzigingen in een bewaarde playlist worden automatisch
opgeslagen, ook wanneer je de tab hernoemt. Het kruisje sluit een bewaarde tab;
de playlist blijft beschikbaar in de bibliotheek.
Playlisttabs kunnen worden toegevoegd, geselecteerd, hernoemd door dubbel te Playlisttabs kunnen worden toegevoegd, geselecteerd, hernoemd door dubbel te
klikken en verwijderd. Tracks kunnen worden afgespeeld, verwijderd en met klikken en gesloten. Tracks kunnen worden afgespeeld, verwijderd en met
drag-and-drop verplaatst. Tabnamen, tabvolgorde en alle tracklijsten worden na drag-and-drop verplaatst. Tabnamen, tabvolgorde en alle tracklijsten worden na
iedere wijziging transactioneel opgeslagen. Een verwijderde iedere wijziging transactioneel opgeslagen. Alleen een gesloten tab die niet
tab verdwijnt daarbij ook uit de keystore. Voor iedere gebruiker bevat de key in de bibliotheek is bewaard, verdwijnt ook uit de keystore. Voor iedere gebruiker
`playlists-for-<username>` de geordende lijst met playlist-GUIDs. Onder iedere bevat `playlists-for-<username>` de geordende lijst met geopende playlist-GUIDs,
GUID-key staan de naam en tracks van die playlist. Tracks uit verschillende en `saved-playlists-for-<username>` de bewaarde playlists. Onder iedere
GUID-key staan de naam en tracks van die playlist. Bestaande tabs worden niet
automatisch aan de bibliotheek toegevoegd. Tracks uit verschillende
geconfigureerde libraries mogen in dezelfde playlist staan; ontbrekende of geconfigureerde libraries mogen in dezelfde playlist staan; ontbrekende of
buiten de libraries gelegen bestanden worden bij het laden overgeslagen. buiten de libraries gelegen bestanden worden bij het laden overgeslagen.
Iedere aangemelde gebruiker heeft daarbij een eigen playlistverzameling. Als Iedere aangemelde gebruiker heeft daarbij een eigen playlistverzameling. Als
@@ -193,22 +204,20 @@ opgeruimd zodra ze niet meer nodig zijn en bij afsluiten van de agent.
### Systeemvak ### Systeemvak
De GUI gebruikt optioneel de open-source SDL3-tray-API. Als zowel het Racket- De GUI gebruikt het Racket-pakket `racket-tray`. Minimaliseren en de
pakket `sdl3` als de native SDL3-, SDL3_image- en SDL3_ttf-libraries aanwezig vensterknop verbergen de agent in het systeemvak. Het menu bevat
zijn, sluit de vensterknop de agent naar het systeemvak. Het menu bevat **RKT Web Player Agent openen** en **Afsluiten**; openen herstelt ook een
**RKT Web Player Agent openen** en **Afsluiten**. Zonder SDL3 blijft de agent geminimaliseerd venster. De tray is onderdeel van de normale package-
gewoon werken en sluit de vensterknop het proces af. Er wordt geen PowerShell- dependencies en vereist geen SDL3-pakket of SDL3-libraries meer.
proces of externe tray-helper gestart.
Windows en macOS gebruiken de native systeemvoorzieningen zonder aanvullende
runtime. Op Linux gebruikt `racket-tray` Ayatana AppIndicator voor GTK3. Op
Debian en Ubuntu kan die runtime zo worden geïnstalleerd:
```console ```console
raco pkg install sdl3 sudo apt install libayatana-appindicator3-1
``` ```
SDL3 is bewust geen verplichte package-dependency: de agent blijft daardoor
klein voor gebruikers die geen systeemvak nodig hebben. Op Windows moeten de
bijbehorende native DLL's daarnaast vindbaar zijn, bijvoorbeeld naast het
gebouwde executable of via `PATH`.
### CLI playback agent ### CLI playback agent
De headless agent gebruikt exact dezelfde polling-, download-, audio- en De headless agent gebruikt exact dezelfde polling-, download-, audio- en
@@ -244,6 +253,8 @@ geen TLS heeft.
```console ```console
raco test private/users.rkt private/library.rkt private/player.rkt \ raco test private/users.rkt private/library.rkt private/player.rkt \
private/player-agent-config.rkt private/server.rkt private-player-agent/player-agent-config.rkt
node tests/player-state.test.mjs
node tests/playlist-library.test.mjs
raco setup --check-pkg-deps rkt-web-player raco setup --check-pkg-deps rkt-web-player
``` ```
+3 -1
View File
@@ -12,14 +12,16 @@
"gui-lib" "gui-lib"
"keystore" "keystore"
"libargon2" "libargon2"
"net-ip-lib"
"net-lib" "net-lib"
"web-server-lib" "web-server-lib"
"racket-audio" "racket-audio"
"racket-audio-dlna" "racket-audio-dlna"
"racket-mimetypes" "racket-mimetypes"
"racket-sonos" "racket-sonos"
"racket-tray"
"racket-upnp" "racket-upnp"
"simple-ini" ("simple-ini" #:version "0.3.3")
"simple-log" "simple-log"
"uuid")) "uuid"))
+57 -12
View File
@@ -3,7 +3,6 @@
(require racket/cmdline (require racket/cmdline
racket/contract racket/contract
racket/list racket/list
racket/mpair
racket/runtime-path racket/runtime-path
racket/string racket/string
simple-ini simple-ini
@@ -24,19 +23,19 @@
(define-runtime-path default-playlist-keystore (define-runtime-path default-playlist-keystore
"data/playlists.keystore") "data/playlists.keystore")
(define-runtime-path default-log-file
"data/rkt-web-player.log")
;;; Returns the key/value pairs from one INI section in source order.
(define (ini-section-key-values config section-name) (define (ini-section-key-values config section-name)
(let ((section (assoc section-name (mcdr config)))) (map (λ (key)
(if section (cons (symbol->string key)
(for/list ((line (in-list (cdr section))) (ini-get config section-name key #f)))
#:when (and (pair? line) (ini-keys config section-name)))
(eq? (car line) 'keyval)))
(cons (symbol->string (cadr line))
(caddr line)))
'())))
(define (configuration-list value defaults) (define (configuration-list value defaults)
(cond (cond
((list? value) (map (lambda (item) (format "~a" item)) value)) ((list? value) (map (λ (item) (format "~a" item)) value))
((and (string? value) ((and (string? value)
(not (string=? (string-trim value) ""))) (not (string=? (string-trim value) "")))
(map string-trim (string-split value ";"))) (map string-trim (string-split value ";")))
@@ -65,6 +64,12 @@
#:local-output? [local-output? #t] #:local-output? [local-output? #t]
#:playlist-keystore #:playlist-keystore
[playlist-keystore default-playlist-keystore] [playlist-keystore default-playlist-keystore]
#:log-file
[log-file default-log-file]
#:log-retention-days
[log-retention-days 7]
#:log-level
[log-level 'debug]
#:launch-browser? [launch-browser? #t]) #:launch-browser? [launch-browser? #t])
(->* ((listof library-spec/c)) (->* ((listof library-spec/c))
(#:allowed-agent-ids (listof string?) (#:allowed-agent-ids (listof string?)
@@ -76,8 +81,15 @@
#:dlna-port exact-positive-integer? #:dlna-port exact-positive-integer?
#:local-output? boolean? #:local-output? boolean?
#:playlist-keystore (or/c path-string? #f) #:playlist-keystore (or/c path-string? #f)
#:log-file path-string?
#:log-retention-days exact-positive-integer?
#:log-level symbol?
#:launch-browser? boolean?) #:launch-browser? boolean?)
any) any)
(sl-log-to-rotating-file log-file log-retention-days)
(sl-set-log-level log-level)
(let* ((libraries (make-music-libraries music-paths)) (let* ((libraries (make-music-libraries music-paths))
(player (make-player libraries (player (make-player libraries
#:allowed-agent-ids allowed-agent-ids #:allowed-agent-ids allowed-agent-ids
@@ -104,6 +116,23 @@
(λ () (λ ()
(player-close! player))))) (player-close! player)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module main.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require rackunit)
(let ((config (make-ini)))
(ini-set! config 'libraries 'music "/srv/music")
(ini-set! config 'server 'port 8080)
(ini-set! config 'libraries 'archive "/srv/archive")
(check-equal?
(ini-section-key-values config 'libraries)
'(("music" . "/srv/music")
("archive" . "/srv/archive")))
(check-equal? (ini-section-key-values config 'missing) '())))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Command line ;; Command line
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -115,6 +144,7 @@
(define playlist-keystore #f) (define playlist-keystore #f)
(define launch-browser? #t) (define launch-browser? #t)
(define config-file #f) (define config-file #f)
(define log-file #f)
(define music-paths (define music-paths
(command-line (command-line
@@ -138,6 +168,9 @@
[("--no-browser") [("--no-browser")
"Do not open the web interface automatically" "Do not open the web interface automatically"
(set! launch-browser? #f)] (set! launch-browser? #f)]
[("--log-file") path
"Log file path, retention is normally set to 7 days, but can be changed in the INI file"
(set! log-file path)]
#:args paths #:args paths
paths)) paths))
@@ -189,7 +222,6 @@
music-paths music-paths
configured-paths)) configured-paths))
(sl-log-to-display)
(run-web-player (run-web-player
all-libraries all-libraries
#:allowed-agent-ids allowed-agent-ids #:allowed-agent-ids allowed-agent-ids
@@ -211,4 +243,17 @@
(not (string=? (string-trim (format "~a" configured)) "")) (not (string=? (string-trim (format "~a" configured)) ""))
configured)) configured))
default-playlist-keystore) default-playlist-keystore)
#:launch-browser? launch-browser?)) #:launch-browser? launch-browser?
#:log-file
(if (eq? log-file #f)
default-log-file
(if (eq? (ini-get config 'logging 'log-file #f) #f)
log-file
(ini-get config 'logging 'log-file default-log-file)))
#:log-retention-days
(ini-get config 'logging 'log-retention-days 7)
#:log-level
(string->symbol
(format "~a" (ini-get config 'logging 'log-level 'debug)))
)
)
+111 -77
View File
@@ -1,95 +1,129 @@
#lang racket/base #lang racket/base
(require racket/cmdline (require racket/cmdline
racket/contract
racket/format racket/format
racket/string racket/string
simple-log simple-log
"private/player-agent-config.rkt" "private-player-agent/player-agent-config.rkt"
"private/player-agent-core.rkt") "private-player-agent/player-agent-core.rkt")
(provide run-player-agent-cli) (provide run-player-agent-cli)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Produce a concise description of the current agent track.
; pre : track is #f or a server-supplied track hash.
; post : No state is changed.
; result : Artist and title when available, otherwise title or filename.
; internals:
; The CLI deliberately uses server metadata and does not reopen the
; downloaded media file solely for display purposes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (track-description track) (define (track-description track)
(cond (cond
((not track) "geen track") ((not track) "geen track")
(else (else
(define title (hash-ref track 'title #f)) (let ((title (hash-ref track 'title #f))
(define artist (hash-ref track 'artist #f)) (artist (hash-ref track 'artist #f))
(define filename (hash-ref track 'filename "onbekend")) (filename (hash-ref track 'filename "onbekend")))
(cond (cond
((and artist title (not (string=? artist ""))) ((and artist title (not (string=? artist "")))
(format "~a — ~a" artist title)) (format "~a — ~a" artist title))
(title title) (title title)
(else filename))))) (else filename))))))
(define (run-player-agent-cli #:server-url [server-override #f] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#:name [name-override #f] ;; Provided functions
#:config-file [config-file #f]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Run the headless polling playback agent.
; pre : Overrides are #f or valid strings/paths and the configured server
; is reachable for useful operation.
; post : Configuration is persisted; runtime resources are released after
; interruption or an exception.
; result : Void after the agent has shut down.
; internals:
; One monitor thread prints only changed playback summaries. The
; shared runtime owns polling, downloads, audio and prefetch state.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (run-player-agent-cli #:server-url [server-override #f]
#:name [name-override #f]
#:config-file [config-file #f])
(->* ()
(#:server-url (or/c string? #f)
#:name (or/c string? #f)
#:config-file (or/c path-string? #f))
void?)
(sl-log-to-display) (sl-log-to-display)
(define loaded (let* ((loaded
(if config-file (if config-file
(load-player-agent-config config-file) (load-player-agent-config config-file)
(load-player-agent-config))) (load-player-agent-config)))
(define server-url (server-url
(string-trim (or server-override (string-trim (or server-override
(player-agent-config-server-url loaded)))) (player-agent-config-server-url loaded))))
(define name (name
(string-trim (or name-override (string-trim (or name-override
(player-agent-config-name loaded)))) (player-agent-config-name loaded))))
(define config (config
(struct-copy player-agent-config loaded (struct-copy player-agent-config loaded
(server-url server-url) (server-url server-url)
(name name))) (name name)))
(save-player-agent-config! config) (write-status
(λ (message)
(define (write-status message) (printf "[agent] ~a~n" message)
(printf "[agent] ~a~n" message) (flush-output)))
(flush-output)) (runtime
(make-player-agent-runtime
(define runtime server-url
(make-player-agent-runtime name
server-url (player-agent-config-app-id config)
name #:status-callback write-status
(player-agent-config-app-id config) #:denied-callback
#:status-callback write-status (λ (message)
#:denied-callback (eprintf "~a~n" message)
(lambda (message) (flush-output (current-error-port)))))
(eprintf "~a~n" message) (monitor #f))
(flush-output (current-error-port))))) (save-player-agent-config! config)
(printf "RKT Web Player CLI Agent~n")
(printf "RKT Web Player CLI Agent~n") (printf "Naam: ~a~n" name)
(printf "Naam: ~a~n" name) (printf "Server: ~a~n" server-url)
(printf "Server: ~a~n" server-url) (printf "Applicatie-ID: ~a~n" (player-agent-config-app-id config))
(printf "Applicatie-ID: ~a~n" (player-agent-config-app-id config)) (printf "Stoppen: Ctrl+C~n")
(printf "Stoppen: Ctrl+C~n") (flush-output)
(flush-output) (dynamic-wind
(λ ()
(define monitor #f) ((player-agent-runtime-start! runtime))
(dynamic-wind (set! monitor
(lambda () (thread
((player-agent-runtime-start! runtime)) (λ ()
(set! monitor (let loop ((previous #f))
(thread (let* ((snapshot
(lambda () ((player-agent-runtime-snapshot runtime)))
(let loop ((previous #f)) (summary
(define snapshot (cons
((player-agent-runtime-snapshot runtime))) (hash-ref snapshot 'state "stopped")
(define summary (track-description
(cons (hash-ref snapshot 'state "stopped") ((player-agent-runtime-current-track runtime))))))
(track-description (unless (equal? summary previous)
((player-agent-runtime-current-track runtime))))) (printf "[playback] ~a — ~a~n"
(unless (equal? summary previous) (car summary)
(printf "[playback] ~a — ~a~n" (car summary) (cdr summary)) (cdr summary))
(flush-output)) (flush-output))
(sleep 1) (sleep 1)
(loop summary)))))) (loop summary)))))))
(lambda () (λ ()
(with-handlers ((exn:break? void)) (with-handlers ((exn:break? void))
(sync never-evt))) (sync never-evt)))
(lambda () (λ ()
(when (and monitor (not (thread-dead? monitor))) (when (and monitor (not (thread-dead? monitor)))
(kill-thread monitor)) (kill-thread monitor))
((player-agent-runtime-shutdown! runtime))))) ((player-agent-runtime-shutdown! runtime))))))
(module+ main (module+ main
(define server-url #f) (define server-url #f)
+20 -5
View File
@@ -1,5 +1,8 @@
#lang racket/base #lang racket/base
(require racket/class
racket/contract)
(provide run-player-agent (provide run-player-agent
run-player-agent-cli) run-player-agent-cli)
@@ -8,9 +11,13 @@
; pre : A graphical desktop is available. ; pre : A graphical desktop is available.
; post : The agent remains active until its window is closed. ; post : The agent remains active until its window is closed.
; result : The GUI frame returned by the implementation. ; result : The GUI frame returned by the implementation.
; internals:
; The GUI module is loaded only when this procedure is called. This
; keeps command-line use independent of racket/gui initialization.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (run-player-agent) (define/contract (run-player-agent)
((dynamic-require "private/player-agent-gui.rkt" (-> object?)
((dynamic-require "private-player-agent/player-agent-gui.rkt"
'run-player-agent-gui))) 'run-player-agent-gui)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -18,10 +25,18 @@
; pre : The configured server is reachable. ; pre : The configured server is reachable.
; post : The agent remains active until interrupted. ; post : The agent remains active until interrupted.
; result : Void after the agent has shut down. ; result : Void after the agent has shut down.
; internals:
; Delayed loading keeps the graphical and headless entrypoints
; separate while preserving the existing public module API.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (run-player-agent-cli #:server-url [server-url #f] (define/contract (run-player-agent-cli #:server-url [server-url #f]
#:name [name #f] #:name [name #f]
#:config-file [config-file #f]) #:config-file [config-file #f])
(->* ()
(#:server-url (or/c string? #f)
#:name (or/c string? #f)
#:config-file (or/c path-string? #f))
void?)
((dynamic-require "player-agent-cli.rkt" 'run-player-agent-cli) ((dynamic-require "player-agent-cli.rkt" 'run-player-agent-cli)
#:server-url server-url #:server-url server-url
#:name name #:name name
@@ -0,0 +1,114 @@
#lang racket/base
(require file/sha1
racket/contract
racket/os
racket/path
racket/random
racket/string
simple-ini)
(provide (struct-out player-agent-config)
load-player-agent-config
save-player-agent-config!
valid-app-id?)
(struct player-agent-config (file ini app-id server-url name) #:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (fresh-app-id)
(bytes->hex-string (crypto-random-bytes 32)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Recognize a playback-agent application identifier.
; pre : value is any Racket value.
; post : No state is changed.
; result : #t only for a 256-bit identifier encoded as 64 hexadecimal digits.
; internals:
; Identifiers are accepted case-insensitively and normalized while
; loading configuration.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (valid-app-id? value)
(-> any/c boolean?)
(and (string? value)
(regexp-match? #px"^[0-9a-fA-F]{64}$" value)
#t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Load the playback-agent INI configuration.
; pre : file is a writable path-string understood by simple-ini.
; post : Missing defaults and a generated application ID are persisted.
; result : A player-agent-config value containing normalized settings.
; internals:
; Reusing the stored application ID preserves the server allowlist;
; only a missing or malformed identifier is replaced.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (load-player-agent-config
[file (get-ini-file 'rkt-web-player-agent)])
(->* () (path-string?) player-agent-config?)
(let* ((ini (file->ini file))
(configured-id (ini-get ini 'agent 'app-id #f))
(value
(player-agent-config
file
ini
(if (valid-app-id? configured-id)
(string-downcase configured-id)
(fresh-app-id))
(ini-get ini 'server 'url "http://127.0.0.1:8080")
(ini-get ini 'agent 'name
(format "~a playback" (gethostname))))))
(save-player-agent-config! value)
value))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Persist a playback-agent configuration.
; pre : value is a player-agent-config with a writable file path.
; post : Its ID, name and server URL are stored in a private INI file.
; result : The result returned by simple-ini's ini->file procedure.
; internals:
; The existing parsed INI value is updated directly so unrelated
; settings remain intact.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (save-player-agent-config! value)
(-> player-agent-config? void?)
(let ((ini (player-agent-config-ini value)))
(ini-set! ini 'agent 'app-id (player-agent-config-app-id value))
(ini-set! ini 'agent 'name (player-agent-config-name value))
(ini-set! ini 'server 'url (player-agent-config-server-url value))
(ini->file ini (player-agent-config-file value) #:private? #t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module library.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require rackunit
racket/file)
(define test-directory (make-temporary-file "rkt-agent-config-~a" 'directory))
(define test-file (build-path test-directory "agent.ini"))
(dynamic-wind
void
(λ ()
(let* ((first (load-player-agent-config test-file))
(changed
(struct-copy player-agent-config first
(server-url "https://music.example.test")
(name "Test output"))))
(check-true (valid-app-id? (player-agent-config-app-id first)))
(save-player-agent-config! changed)
(let ((second (load-player-agent-config test-file)))
(check-equal? (player-agent-config-app-id second)
(player-agent-config-app-id first))
(check-equal? (player-agent-config-server-url second)
"https://music.example.test")
(check-equal? (player-agent-config-name second) "Test output"))))
(λ () (delete-directory/files test-directory))))
+524
View File
@@ -0,0 +1,524 @@
#lang racket/base
(require json
net/url
racket-audio
racket/contract
racket/file
racket/path
racket/port
racket/string
simple-log
"player-agent-translate.rkt")
(provide (struct-out player-agent-runtime)
make-player-agent-runtime)
(sl-def-log player-agent)
(struct exn:fail:agent-denied exn:fail () #:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Expose the small procedure-based interface of a running agent.
; pre : Constructor fields are lifecycle/query procedures and a stable ID.
; post : Creating or recognizing a value changes no external state.
; result : player-agent-runtime? recognizes values returned by the factory.
; internals: make-player-agent-runtime stores its local start!, reconnect!,
; shutdown!, snapshot and current-track procedures in this struct.
; Those procedures retain access to the factory closure, keeping the
; shared polling and audio state private without introducing a class.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(struct player-agent-runtime
(start! reconnect! shutdown! snapshot current-track running? app-id)
#:transparent)
;;; Normalizes a configured server address and converts it to a URL value.
(define (base-url value)
(string->url
(regexp-replace #px"/+$" (string-trim value) "")))
;;; Resolves an agent API path relative to a normalized server URL.
(define (endpoint-url base path)
(combine-url/relative (base-url base) path))
;;; Posts JSON to an agent API endpoint and reads its JSON response.
;;; Authorization failures receive a distinct exception for poll-loop.
(define (post-json base path data)
(let ((input
(post-pure-port
(endpoint-url base path)
(jsexpr->bytes data)
(list "Content-Type: application/json"
"Cache-Control: no-store"))))
(dynamic-wind
void
(λ ()
(let ((response (read-json input)))
(when (and (hash? response)
(string? (hash-ref response 'error #f)))
(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)))))
;;; Converts racket-audio states to the state names sent to the web player.
(define (normal-state state)
(cond
((memq state '(initialized no-media)) "stopped")
((eq? state 'transitioning) "starting")
(else (symbol->string state))))
;;; Deletes a temporary media file and logs recoverable deletion failures.
(define (safe-delete-file file)
(when (and file (file-exists? file))
(with-handlers ((exn:fail?
(λ (exception)
(warn-player-agent
"Could not remove temporary media file ~a: ~a"
file
(exn-message exception)))))
(delete-file file))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create the headless polling and audio runtime for one agent.
; pre : Server URL, display name and application ID are strings; callbacks
; accept the status/denial messages supplied to them.
; post : Mutable state is initialized but no worker thread or audio backend
; is started until the returned start! procedure is called.
; result : A player-agent-runtime containing its lifecycle/query procedures.
; internals: start! launches poll-loop, which registers through post-json and
; sends snapshots until it receives a command. A command worker runs
; execute-command! and acknowledges it only after completion.
; ensure-audio! connects racket-audio callbacks to update-from-audio!
; and advance-at-decoder-eof!. with-agent-state protects their shared
; state; stop! and shutdown! stop threads, audio and cached files.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (make-player-agent-runtime initial-server-url
initial-name
app-id
#:status-callback
[status-callback void]
#:denied-callback
[denied-callback void])
(->* (string? string? string?)
(#:status-callback (-> string? any/c)
#:denied-callback (-> string? any/c))
player-agent-runtime?)
(let* ((server-url initial-server-url)
(assigned-name initial-name)
(state-lock (make-semaphore 1))
(worker #f)
(command-worker #f)
(executing-command-id 0)
(running #f)
(authorization-notified? #f)
(audio #f)
(current-media-key #f)
(cached-media (make-hash))
(prefetched-track #f)
(auto-started-key #f)
(pending-auto-music-id #f)
(music-tracks (make-hash))
(current-track-value #f)
(acknowledged-command 0)
(ended-counter 0)
(logical-volume 50)
(agent-state
(hasheq 'state "stopped"
'position 0
'duration 'null
'rate 'null
'channels 'null
'bits 'null
'format ""
'volume logical-volume
'error 'null)))
;;; Runs a procedure while holding the semaphore for shared agent state.
(define (with-agent-state proc)
(call-with-semaphore state-lock proc))
;;; Replaces an unavailable state value with its JSON fallback.
(define (state-value value fallback)
(if (eq? value #f) fallback value))
;;; Returns the latest audio state while holding the state semaphore.
(define (snapshot)
(with-agent-state (λ () agent-state)))
;;; Returns the currently audible track while holding the state semaphore.
(define (current-track)
(with-agent-state (λ () current-track-value)))
;;; Stores an error in the state reported by the next poll.
(define (set-agent-error! message)
(with-agent-state
(λ ()
(set! agent-state (hash-set agent-state 'error message)))))
;;; Removes an earlier error from the state reported by the next poll.
(define (clear-agent-error!)
(with-agent-state
(λ ()
(set! agent-state (hash-set agent-state 'error 'null)))))
;;; Copies racket-audio state into the agent snapshot.
;;; It also confirms when a prefetched track has become audible.
(define (update-from-audio! state full-state)
(with-agent-state
(λ ()
(let ((audible-music-id (hash-ref full-state 'at-music-id #f)))
(set! agent-state
(hasheq
'state (normal-state state)
'position (state-value (hash-ref full-state 'at-second #f) 0)
'duration (state-value (hash-ref full-state 'duration #f) 'null)
'rate (state-value (hash-ref full-state 'rate #f) 'null)
'channels (state-value (hash-ref full-state 'channels #f) 'null)
'bits (state-value (hash-ref full-state 'bits #f) 'null)
'format (let ((decoder (hash-ref full-state 'decoder #f)))
(if decoder (format "~a" decoder) ""))
'volume logical-volume
'error 'null))
(when (and pending-auto-music-id
(number? audible-music-id)
(= pending-auto-music-id audible-music-id))
(let ((audible-track
(hash-ref music-tracks audible-music-id #f)))
(when audible-track
(set! current-track-value audible-track)
(hash-clear! music-tracks)
(hash-set! music-tracks audible-music-id audible-track)))
(set! pending-auto-music-id #f)
(set! ended-counter (+ ended-counter 1)))))))
;;; Creates and configures the audio player on first use.
;;; Its callbacks update reported state and continue prefetched playback.
(define (ensure-audio!)
(unless audio
(set! audio
(make-audio-player
(λ (_handle state full-state)
(update-from-audio! state full-state))
(λ (handle)
(advance-at-decoder-eof! handle))))
(audio-ao-buf-ms! audio 500)
(audio-buf-seconds! audio 4 10)
(let ((scaled (/ logical-volume 100.0)))
(audio-volume! audio (* 100.0 scaled scaled))))
audio)
;;; Downloads one protected media resource to a temporary local file.
;;; A failed download closes its port and removes its partial file.
(define (download-media! token filename)
(let* ((extension
(or (path-get-extension (string->path filename)) #""))
(target
(make-temporary-file
(string-append "rkt-player-agent-~a"
(bytes->string/utf-8 extension))))
(path (format "/api/agent/media/~a/~a" app-id token))
(input (get-pure-port (endpoint-url server-url path))))
(with-handlers ((exn:fail?
(λ (exception)
(close-input-port input)
(safe-delete-file target)
(raise exception))))
(call-with-output-file
target
(λ (output) (copy-port input output))
#:exists 'truncate/replace)
(close-input-port input)
target)))
;;; Selects the stable cache key carried by a playback command.
(define (command-cache-key data)
(hash-ref data 'cacheKey (hash-ref data 'mediaToken)))
;;; Returns cached media or downloads and records it when absent.
(define (ensure-media-cached! data)
(let* ((key (command-cache-key data))
(found (hash-ref cached-media key #f)))
(if (and found (file-exists? found))
found
(let ((downloaded
(download-media!
(hash-ref data 'mediaToken)
(hash-ref data 'filename "track"))))
(hash-set! cached-media key downloaded)
downloaded))))
;;; Removes every cached media file except the entry identified by keep-key.
(define (discard-unused-media! keep-key)
(let loop ((remaining (hash->list cached-media)))
(unless (null? remaining)
(let ((entry (car remaining)))
(unless (equal? (car entry) keep-key)
(safe-delete-file (cdr entry))
(hash-remove! cached-media (car entry))))
(loop (cdr remaining)))))
;;; Continues with prefetched media when the current decoder reaches EOF.
;;; Decoder EOF precedes audible EOF, so audio-play! queues behind the buffer.
(define (advance-at-decoder-eof! handle)
(let ((prepared
(with-agent-state
(λ ()
(let ((value prefetched-track))
(set! prefetched-track #f)
value)))))
(cond
(prepared
(let* ((data (car prepared))
(path (cdr prepared))
(key (command-cache-key data)))
(with-handlers
((exn:fail?
(λ (exception)
(warn-player-agent "Could not start prefetched track: ~a"
(exn-message exception))
(set-agent-error! (exn-message exception))
(with-agent-state
(λ () (set! ended-counter (+ ended-counter 1)))))))
(let ((music-id (audio-play! handle path)))
(info-player-agent "Queued prefetched track ~a as music id ~a"
(hash-ref data 'filename "track")
music-id)
(set! current-media-key key)
(discard-unused-media! key)
(with-agent-state
(λ ()
(hash-set! music-tracks music-id data)
(set! auto-started-key key)
(set! pending-auto-music-id music-id)))))))
(else
(warn-player-agent
"Decoder reached EOF before the next track was prefetched")
(with-agent-state
(λ () (set! ended-counter (+ ended-counter 1))))))))
;;; Applies one server command to audio, cache and reported agent state.
;;; Play and prefetch commands also maintain gapless track bookkeeping.
(define (execute-command! command)
(let ((action (hash-ref command 'action ""))
(data (hash-ref command 'data (hasheq))))
(info-player-agent "Executing command ~a" action)
(cond
((string=? action "play")
(let* ((next-key (command-cache-key data))
(already-started?
(with-agent-state
(λ ()
(let ((matches?
(and auto-started-key
(equal? auto-started-key next-key))))
(when matches?
(set! auto-started-key #f))
matches?)))))
(with-agent-state
(λ () (set! current-track-value data)))
(unless already-started?
(with-agent-state
(λ ()
(set! prefetched-track #f)
(set! auto-started-key #f)
(set! pending-auto-music-id #f)
(set! agent-state
(hash-set
(hash-set agent-state 'state "starting")
'error 'null))))
(let* ((next-media (ensure-media-cached! data))
;; audio-play! interrupts and closes the previous decoder.
(music-id (audio-play! (ensure-audio!) next-media)))
(with-agent-state
(λ ()
(hash-clear! music-tracks)
(hash-set! music-tracks music-id data)))
(set! current-media-key next-key)
(discard-unused-media! next-key)))))
((string=? action "prefetch")
(let ((key (command-cache-key data))
(path (ensure-media-cached! data)))
(with-agent-state
(λ () (set! prefetched-track (cons data path))))
(info-player-agent "Prefetched ~a"
(hash-ref data 'filename "track"))
(let loop ((remaining (hash->list cached-media)))
(unless (null? remaining)
(let ((entry (car remaining)))
(unless (or (equal? (car entry) current-media-key)
(equal? (car entry) key))
(safe-delete-file (cdr entry))
(hash-remove! cached-media (car entry))))
(loop (cdr remaining))))))
((string=? action "pause")
(audio-pause! (ensure-audio!) #t))
((string=? action "resume")
(audio-pause! (ensure-audio!) #f))
((string=? action "stop")
(with-agent-state
(λ ()
(set! prefetched-track #f)
(set! auto-started-key #f)
(set! pending-auto-music-id #f)))
(when audio
(audio-stop! audio)))
((string=? action "seek")
(audio-seek! (ensure-audio!) (hash-ref data 'percentage 0)))
((string=? action "volume")
(set! logical-volume (min 100 (max 0 (hash-ref data 'value 50))))
(let ((scaled (/ logical-volume 100.0)))
(audio-volume! (ensure-audio!) (* 100.0 scaled scaled)))
(with-agent-state
(λ ()
(set! agent-state
(hash-set agent-state 'volume logical-volume)))))
(else
(error 'player-agent "unknown command: ~a" action)))))
;;; Registers the agent and repeatedly exchanges state for server commands.
;;; Connection and authorization failures are reported before a delayed retry.
(define (poll-loop)
(with-handlers
((exn:fail:agent-denied?
(λ (exception)
(let ((message (format (tr 'denied-message) app-id)))
(warn-player-agent "Agent authorization refused: ~a"
(exn-message exception))
(set-agent-error! message)
(status-callback
(tr 'unauthorized-status))
(unless authorization-notified?
(set! authorization-notified? #t)
(denied-callback message))
(when running
(sleep 3)
(poll-loop)))))
(exn:fail?
(λ (exception)
(warn-player-agent "Connection cycle failed: ~a"
(exn-message exception))
(set-agent-error! (exn-message exception))
(status-callback
(format (tr 'disconnected) (exn-message exception)))
(when running
(sleep 3)
(poll-loop)))))
(post-json server-url
"/api/agent/register"
(hasheq 'appId app-id 'name assigned-name))
(clear-agent-error!)
(status-callback (tr 'connected))
(info-player-agent "Registered at ~a as ~a" server-url assigned-name)
(let loop ()
(when running
(let* ((response
(post-json
server-url
"/api/agent/poll"
(hasheq 'appId app-id
'name assigned-name
'ack acknowledged-command
'endedCounter ended-counter
'state (snapshot))))
(command (hash-ref response 'command 'null)))
(when (and (hash? command)
(> (hash-ref command 'id 0) acknowledged-command)
(not (= (hash-ref command 'id 0)
executing-command-id)))
(set! executing-command-id (hash-ref command 'id))
(set! command-worker
(thread
(λ ()
(with-handlers
((exn:fail?
(λ (exception)
(warn-player-agent "Command failed: ~a"
(exn-message exception))
(set-agent-error! (exn-message exception)))))
(clear-agent-error!)
(execute-command! command))
(set! acknowledged-command (hash-ref command 'id))
(set! executing-command-id 0)
(set! command-worker #f))))))
(sleep 1)
(loop)))))
;;; Starts the polling worker once and reports the connecting state.
(define (start!)
(unless running
(set! running #t)
(status-callback (tr 'connecting))
(set! worker (thread poll-loop))))
;;; Stops polling and command workers and clears their lifecycle state.
(define (stop!)
(set! running #f)
(when (and worker (not (thread-dead? worker)))
(kill-thread worker))
(when (and command-worker (not (thread-dead? command-worker)))
(kill-thread command-worker))
(set! worker #f)
(set! command-worker #f)
(set! executing-command-id 0))
;;; Restarts the runtime with a new normalized server address and name.
(define (reconnect! new-server-url new-name)
(stop!)
(set! authorization-notified? #f)
(set! server-url (string-trim new-server-url))
(set! assigned-name (string-trim new-name))
(start!))
;;; Stops the runtime, closes audio and removes all cached media files.
(define (shutdown!)
(stop!)
(when audio
(with-handlers ((exn:fail? void))
(audio-quit! audio))
(set! audio #f))
(let loop ((paths (hash-values cached-media)))
(unless (null? paths)
(safe-delete-file (car paths))
(loop (cdr paths))))
(hash-clear! cached-media))
(player-agent-runtime start!
reconnect!
shutdown!
snapshot
current-track
(λ () running)
app-id)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module player-agent-core.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require rackunit)
(check-equal? (normal-state 'initialized) "stopped")
(check-equal? (normal-state 'transitioning) "starting")
(check-equal? (normal-state 'playing) "playing")
(let* ((app-id (make-string 64 #\a))
(runtime
(make-player-agent-runtime "http://127.0.0.1:1234"
"Test agent"
app-id)))
(check-false ((player-agent-runtime-running? runtime)))
(check-false ((player-agent-runtime-current-track runtime)))
(check-equal?
(hash-ref ((player-agent-runtime-snapshot runtime)) 'state)
"stopped")
(check-equal? (player-agent-runtime-app-id runtime) app-id)))
+417
View File
@@ -0,0 +1,417 @@
#lang racket/base
(require racket/class
racket/contract
racket/format
racket/gui/base
racket/os
racket/runtime-path
racket/string
racket-tray
simple-log
"player-agent-config.rkt"
"player-agent-core.rkt"
"player-agent-translate.rkt")
(provide run-player-agent-gui)
(sl-def-log player-agent-gui)
(define log-file
(build-path (find-system-path 'pref-dir)
"rkt-web-player-agent.log"))
(define-runtime-path tray-icon
"../public/rkt-web-player.png")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a labelled text field with compact editor padding.
; pre : label and init-value are strings; panel accepts GUI children.
; post : A text field has been added to panel.
; result : The newly created text-field% object.
; internals:
; Padding is set on the editor because it renders consistently on
; the supported desktop platforms.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (input-field label init-value panel)
(let ((field
(new text-field%
(parent panel)
(label label)
(init-value init-value))))
(send (send field get-editor) set-padding 0 2 0 2)
field))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Format a playback position as hours, minutes and seconds.
; pre : value is any Racket value.
; post : No state is changed.
; result : A zero-padded HH:MM:SS string; invalid values are treated as zero.
; internals:
; Fractional seconds are deliberately rounded down so the displayed
; position never runs ahead of the audio runtime.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (format-time value)
(let* ((seconds
(if (and (number? value) (>= value 0))
(inexact->exact (floor value))
0))
(hours (quotient seconds 3600))
(minutes (quotient (remainder seconds 3600) 60))
(remaining (remainder seconds 60)))
(format "~a:~a:~a"
(~r hours #:min-width 2 #:pad-string "0")
(~r minutes #:min-width 2 #:pad-string "0")
(~r remaining #:min-width 2 #:pad-string "0"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Start the graphical polling playback agent.
; pre : A graphical desktop and the platform support required by
; racket-tray are available.
; post : The agent runtime is started, its frame and tray icon are visible,
; and closing or minimizing the frame hides it in the system tray.
; result : The live frame% object belonging to the playback agent.
; internals:
; The GUI owns only widgets, configuration and lifecycle callbacks.
; Playback and polling remain in player-agent-core.rkt. racket-tray
; owns native tray resources and the portable minimize watcher.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (run-player-agent-gui)
(-> (is-a?/c frame%))
(sl-log-to-file log-file)
(let ((config (load-player-agent-config))
(frame #f)
(runtime #f)
(status-message #f)
(playback-message #f)
(playback-details #f)
(playback-filename #f)
(name-field #f)
(server-field #f)
(connect-button #f)
(playback-timer #f)
(tray #f)
(shutting-down? #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Queue a status-label update in the GUI eventspace.
; pre : message is a string supplied by the agent runtime.
; post : The status widget shows message when it has been created.
; result : Unspecified.
; internals:
; Runtime callbacks can originate outside the GUI eventspace, so
; widget access is always forwarded with queue-callback.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (show-status! message)
(queue-callback
(λ ()
(when status-message
(send status-message set-label message)))
#f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Show a playback-agent authorization failure.
; pre : message is a string supplied by the agent runtime.
; post : A modal error dialog is queued for the agent frame.
; result : Unspecified.
; internals:
; The callback is eventspace-safe for the same reason as the
; status callback above.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (show-denial! message)
(queue-callback
(λ ()
(message-box (tr 'denied-title)
message
frame
'(ok stop)))
#f))
(set! runtime
(make-player-agent-runtime
(player-agent-config-server-url config)
(player-agent-config-name config)
(player-agent-config-app-id config)
#:status-callback show-status!
#:denied-callback show-denial!))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Refresh the visible playback summary from the runtime cache.
; pre : runtime exists; the widgets may still be uninitialized.
; post : Initialized playback widgets reflect one coherent cached
; snapshot and its current track.
; result : Unspecified.
; internals:
; This procedure never performs network I/O. The timer reads only
; the cache maintained by player-agent-core.rkt.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (refresh-playback-status!)
(when (and playback-message playback-details playback-filename)
(let* ((snapshot ((player-agent-runtime-snapshot runtime)))
(track ((player-agent-runtime-current-track runtime)))
(state (hash-ref snapshot 'state "stopped"))
(title (and track (hash-ref track 'title #f)))
(artist (and track (hash-ref track 'artist #f)))
(filename (and track (hash-ref track 'filename #f)))
(track-number (and track (hash-ref track 'trackNumber #f)))
(track-label
(cond
((and artist (not (string=? artist "")) title)
(format "~a — ~a" artist title))
(title title)
(else (tr 'no-track-selected))))
(prefix
(cond
((string=? state "playing") (tr 'playing))
((string=? state "paused") (tr 'paused))
((string=? state "starting") (tr 'loading))
((string=? state "stopped") (tr 'stopped))
(else state)))
(position (hash-ref snapshot 'position 0))
(duration (hash-ref snapshot 'duration 'null))
(format-name (hash-ref snapshot 'format ""))
(rate (hash-ref snapshot 'rate 'null))
(bits (hash-ref snapshot 'bits 'null))
(channels (hash-ref snapshot 'channels 'null))
(details
(filter
(λ (value) (not (string=? value "")))
(list
(format "~a / ~a"
(format-time position)
(if (number? duration)
(format-time duration)
"--:--:--"))
(if (number? bits) (format "~a bit" bits) "")
(if (number? rate)
(format "~a kHz"
(~r (/ rate 1000.0) #:precision '(= 1)))
"")
(if (number? channels)
(format "~a ~a"
channels
(tr (if (= channels 1) 'channel 'channels)))
"")
(if (and (string? format-name)
(not (string=? format-name "")))
format-name
"")))))
(send playback-message
set-label
(if track
(format "~a~a: ~a"
prefix
(if (number? track-number)
(format " #~a" track-number)
"")
track-label)
(tr 'no-track)))
(send playback-details set-label (string-join details " · "))
(send playback-filename
set-label
(if (and (string? filename)
(not (string=? filename "")))
filename
"")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Persist edited connection settings and reconnect the runtime.
; pre : The name, server and connect widgets have been initialized.
; post : config and the INI file contain normalized values; the runtime
; reconnects with them and the button becomes a reconnect button.
; result : Unspecified.
; internals:
; An empty name receives the same hostname-based default used by
; initial configuration loading.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (reconnect!)
(let* ((next-server (string-trim (send server-field get-value)))
(entered-name (string-trim (send name-field get-value)))
(next-name
(if (string=? entered-name "")
(format "~a playback" (gethostname))
entered-name)))
(set! config
(struct-copy player-agent-config config
(server-url next-server)
(name next-name)))
(save-player-agent-config! config)
(send name-field set-value next-name)
((player-agent-runtime-reconnect! runtime) next-server next-name)
(send connect-button set-label (tr 'reconnect))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Release resources owned by the GUI agent exactly once.
; pre : runtime has been created; timer and tray may be #f.
; post : Playback polling, audio, the GUI timer and native tray resources
; have stopped; subsequent calls do nothing.
; result : Unspecified.
; internals:
; The guard makes this procedure safe from both the window close
; path and the tray Exit action.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (shutdown!)
(unless shutting-down?
(set! shutting-down? #t)
(when playback-timer
(send playback-timer stop))
((player-agent-runtime-shutdown! runtime))
(when tray
(tray-close tray)
(set! tray #f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Terminate the graphical agent from its tray menu.
; pre : frame and runtime have been initialized.
; post : Resources are released and the frame is hidden.
; result : Unspecified.
; internals:
; racket-tray invokes actions in the frame eventspace, so no
; additional GUI callback queue is needed here.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (quit!)
(shutdown!)
(send frame show #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Restore the agent frame from the tray.
; pre : frame has been initialized and has not been destroyed.
; post : frame is visible and no longer iconized.
; result : Unspecified.
; internals:
; De-iconizing is needed because racket-tray hides minimized
; frames instead of changing their iconized state.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (show-window!)
(send frame show #t)
(when (send frame is-iconized?)
(send frame iconize #f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Dispatch a symbolic racket-tray action.
; pre : action is installed in the tray menu below.
; post : 'open restores the frame; 'exit shuts down the agent.
; result : Unspecified.
; internals:
; One callback handles both direct tray activation and menu
; selection on every platform.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-action! action)
(case action
((open) (show-window!))
((exit) (quit!))))
(let* ((agent-frame%
(class frame%
(super-new)
(define/augment (on-close)
(if tray
(send this show #f)
(begin
(shutdown!)
(inner (void) on-close))))))
(new-frame
(new agent-frame%
(label (tr 'app-title))
(width 560)
(height 310))))
(set! frame new-frame))
(let* ((panel
(new vertical-panel%
(parent frame)
(alignment '(left top))))
(server
(input-field (tr 'server)
(player-agent-config-server-url config)
panel))
(name
(input-field (tr 'name)
(player-agent-config-name config)
panel))
(id-field
(input-field (tr 'application-id)
(player-agent-config-app-id config)
panel))
(playback-panel
(new group-box-panel%
(parent panel)
(label (tr 'playback))
(alignment '(left top))
(stretchable-height #f)))
(controls
(new horizontal-panel%
(parent panel)
(alignment '(left center)))))
(set! server-field server)
(set! name-field name)
;; Lock the editor, not the native widget. Disabled Windows controls
;; render their label and text poorly on some display configurations.
(send (send id-field get-editor) lock #t)
(set! playback-message
(new message%
(parent playback-panel)
(label (tr 'no-track))
(auto-resize #t)))
(set! playback-details
(new message%
(parent playback-panel)
(label "00:00:00 / --:--:--")
(auto-resize #t)))
(set! playback-filename
(new message%
(parent playback-panel)
(label "")
(auto-resize #t)))
(set! connect-button
(new button%
(parent controls)
(label (tr 'save-connect))
(callback (λ (_button _event) (reconnect!)))))
(set! status-message
(new message%
(parent controls)
(label (tr 'connecting))
(auto-resize #t))))
(set! playback-timer
(new timer%
(notify-callback refresh-playback-status!)
(interval 500)))
(refresh-playback-status!)
(set! tray
(mk-tray frame
tray-icon
(list tray-action! 'open)
#:hide-on-minimize? #t))
(tray-set-menu!
tray
(list
(list 'open (tr 'tray-open))
'separator
(list 'exit (tr 'quit))))
(send frame show #t)
((player-agent-runtime-start! runtime))
(send connect-button set-label (tr 'reconnect))
frame))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module library.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require rackunit)
;; The runtime path must remain valid after package installation; relying on
;; the development working directory would make the tray fail elsewhere.
(check-true (file-exists? tray-icon)))
@@ -335,6 +335,10 @@
(define (__ id) (define (__ id)
(tr id)) (tr id))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module library.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test (module+ test
(require rackunit) (require rackunit)
+331 -223
View File
@@ -43,81 +43,107 @@
lock) lock)
#:transparent) #:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define playback-start-timeout-ms 8000) (define playback-start-timeout-ms 8000)
;;; Returns the current time used to measure renderer start delays.
(define (now-ms) (define (now-ms)
(current-inexact-milliseconds)) (current-inexact-milliseconds))
;;; Maps renderer-specific transport states to the web player's states.
(define (normalize-state state) (define (normalize-state state)
(cond (cond
((eq? state 'transitioning) 'starting) ((eq? state 'transitioning) 'starting)
((member state '(initialized no-media)) 'stopped) ((member state '(initialized no-media)) 'stopped)
(else state))) (else state)))
;;; Determines whether state or position confirms that playback has started.
;; Position reporting is optional and notably unreliable on some Denon ;; Position reporting is optional and notably unreliable on some Denon
;; renderers. PLAYING, TRANSITIONING or PAUSED is itself confirmation that the ;; renderers. PLAYING, TRANSITIONING or PAUSED is itself confirmation that the
;; renderer accepted the transport. A positive position remains useful for ;; renderer accepted the transport. A positive position remains useful for
;; devices whose transport state lags behind their position response. ;; devices whose transport state lags behind their position response.
(define (renderer-confirms-playback? state position) (define (renderer-confirms-playback? state position)
(or (and (member state '(playing starting paused)) #t) (cond
(and (number? position) (> position 0)))) ((member state '(playing starting paused)) #t)
((and (number? position) (> position 0)) #t)
(else #f)))
;;; Runs a playback operation while holding its synchronization lock.
(define (with-lock playback proc) (define (with-lock playback proc)
(call-with-semaphore (dlna-playback-lock playback) proc)) (call-with-semaphore (dlna-playback-lock playback) proc))
;;; Reads the current playlist through the callback supplied by the owner.
(define (current-tracks playback) (define (current-tracks playback)
((dlna-playback-tracks playback))) ((dlna-playback-tracks playback)))
;;; Checks whether index identifies a track in the current playlist.
(define (valid-index? playback index) (define (valid-index? playback index)
(and (exact-nonnegative-integer? index) (and (exact-nonnegative-integer? index)
(< index (length (current-tracks playback))))) (< index (length (current-tracks playback)))))
;;; Returns the track at index, or #f when the index is invalid.
(define (track-at playback index) (define (track-at playback index)
(and (valid-index? playback index) (if (valid-index? playback index)
(list-ref (current-tracks playback) index))) (list-ref (current-tracks playback) index)
#f))
;;; Produces a complete path string for stable renderer file comparison.
(define (normalized-file file) (define (normalized-file file)
(with-handlers ((exn:fail? (lambda (_) (format "~a" file)))) (with-handlers ((exn:fail? (λ (_) (format "~a" file))))
(path->string (path->complete-path file)))) (path->string (path->complete-path file))))
;;; Compares two track files using the path rules of the current platform.
(define (same-file? first second) (define (same-file? first second)
(and first
second
((if (eq? (system-type 'os) 'windows)
string-ci=?
string=?)
(normalized-file first)
(normalized-file second))))
(define (next-index playback index)
(define count (length (current-tracks playback)))
(cond (cond
((zero? count) #f) ((eq? first #f) #f)
((eq? (dlna-playback-repeat playback) 'one) index) ((eq? second #f) #f)
((< (+ index 1) count) (+ index 1))
((eq? (dlna-playback-repeat playback) 'all) 0)
(else #f)))
(define (track-index-for-info playback info)
(define info-track (dlna-info-track info))
(define file (and info-track (dlna-track-info-file info-track)))
(define prepared (dlna-playback-prepared-index playback))
(cond
((and (valid-index? playback prepared)
(same-file? file (track-file (track-at playback prepared))))
prepared)
(else (else
(for/first ((item (in-list (current-tracks playback))) (let ((same-path? (if (eq? (system-type 'os) 'windows)
(index (in-naturals)) string-ci=?
#:when (same-file? file (track-file item))) string=?)))
index)))) (same-path? (normalized-file first)
(normalized-file second))))))
;;; Selects the following playlist index according to the repeat setting.
(define (next-index playback index)
(let ((count (length (current-tracks playback))))
(cond
((zero? count) #f)
((eq? (dlna-playback-repeat playback) 'one) index)
((< (+ index 1) count) (+ index 1))
((eq? (dlna-playback-repeat playback) 'all) 0)
(else #f))))
;;; Finds the playlist index represented by renderer metadata.
;;; A prepared index is checked first before searching the complete playlist.
(define (track-index-for-info playback info)
(let* ((info-track (dlna-info-track info))
(file (if (eq? info-track #f)
#f
(dlna-track-info-file info-track)))
(prepared (dlna-playback-prepared-index playback)))
(if (and (valid-index? playback prepared)
(same-file? file (track-file (track-at playback prepared))))
prepared
(let loop ((remaining (current-tracks playback))
(index 0))
(cond
((null? remaining) #f)
((same-file? file (track-file (car remaining))) index)
(else
(loop (cdr remaining) (add1 index))))))))
;;; Sends the current playback state and renderer information to the owner.
(define (notify! playback state info) (define (notify! playback state info)
((dlna-playback-update playback) ((dlna-playback-update playback)
state state
(dlna-playback-current-index playback) (dlna-playback-current-index playback)
info)) info))
;;; Records a playback failure and forwards its detail to the error callback.
(define (report-failure! playback detail) (define (report-failure! playback detail)
(set-dlna-playback-playing-seen?! playback #f) (set-dlna-playback-playing-seen?! playback #f)
(set-dlna-playback-progress-seen?! playback #f) (set-dlna-playback-progress-seen?! playback #f)
@@ -126,159 +152,169 @@
(set-dlna-playback-stopped-polls! playback 0) (set-dlna-playback-stopped-polls! playback 0)
((dlna-playback-error playback) detail)) ((dlna-playback-error playback) detail))
;;; Prepares the next track on renderers that support gapless continuation.
(define (prepare-next! playback) (define (prepare-next! playback)
(define current (dlna-playback-current-index playback)) (let ((current (dlna-playback-current-index playback)))
(when (valid-index? playback current) (when (valid-index? playback current)
(define following (next-index playback current)) (let ((following (next-index playback current)))
(cond (cond
((not following) ((eq? following #f)
(set-dlna-playback-prepared-index! playback #f)) (set-dlna-playback-prepared-index! playback #f))
((not (equal? following (dlna-playback-prepared-index playback))) ((not (equal? following (dlna-playback-prepared-index playback)))
(with-handlers (with-handlers
((exn:fail? ((exn:fail?
(lambda (exception) (λ (exception)
(set-dlna-playback-prepared-index! playback #f) (set-dlna-playback-prepared-index! playback #f)
(warn-web-player-dlna (warn-web-player-dlna
"Could not prepare next DLNA track: ~a" "Could not prepare next DLNA track: ~a"
(exn-message exception))))) (exn-message exception)))))
(dlna-player-set-next-file! (dlna-player-set-next-file!
(dlna-playback-player playback) (dlna-playback-player playback)
(track-file (track-at playback following))) (track-file (track-at playback following)))
(set-dlna-playback-prepared-index! playback following)))))) (set-dlna-playback-prepared-index! playback following))))))))
;;; Starts one playlist item while the caller holds the playback lock.
(define (play-index/locked! playback index) (define (play-index/locked! playback index)
(define item (track-at playback index)) (let ((item (track-at playback index)))
(unless item (unless item
(raise-arguments-error (raise-arguments-error
'dlna-playback-play-index! 'dlna-playback-play-index!
"track index is outside the playlist" "track index is outside the playlist"
"index" index)) "index" index))
(with-handlers (with-handlers
((exn:fail? ((exn:fail?
(lambda (exception) (λ (exception)
(report-failure! playback (exn-message exception)) (report-failure! playback (exn-message exception))
(raise exception)))) (raise exception))))
(dlna-player-play! (dlna-playback-player playback) (track-file item)) (dlna-player-play! (dlna-playback-player playback) (track-file item))
(define info (dlna-player-info (dlna-playback-player playback))) (let ((info (dlna-player-info (dlna-playback-player playback))))
(set-dlna-playback-current-index! playback index) (set-dlna-playback-current-index! playback index)
(set-dlna-playback-current-uri! playback (dlna-info-uri info)) (set-dlna-playback-current-uri! playback (dlna-info-uri info))
(set-dlna-playback-prepared-index! playback #f) (set-dlna-playback-prepared-index! playback #f)
(set-dlna-playback-playing-seen?! playback #t) (set-dlna-playback-playing-seen?! playback #t)
(set-dlna-playback-progress-seen?! playback #f) (set-dlna-playback-progress-seen?! playback #f)
(set-dlna-playback-failure-active?! playback #f) (set-dlna-playback-failure-active?! playback #f)
(set-dlna-playback-play-request-ms! playback (now-ms)) (set-dlna-playback-play-request-ms! playback (now-ms))
(set-dlna-playback-stop-requested?! playback #f) (set-dlna-playback-stop-requested?! playback #f)
(set-dlna-playback-stopped-polls! playback 0) (set-dlna-playback-stopped-polls! playback 0)
(notify! playback 'starting info) (notify! playback 'starting info)
(prepare-next! playback))) (prepare-next! playback)))))
;;; Updates the current index when renderer metadata identifies another track.
(define (update-current-track! playback info) (define (update-current-track! playback info)
(define index (track-index-for-info playback info)) (let ((index (track-index-for-info playback info)))
(when (valid-index? playback index) (when (valid-index? playback index)
(unless (equal? index (dlna-playback-current-index playback)) (unless (equal? index (dlna-playback-current-index playback))
(set-dlna-playback-progress-seen?! playback #f) (set-dlna-playback-progress-seen?! playback #f)
(set-dlna-playback-play-request-ms! playback (now-ms))) (set-dlna-playback-play-request-ms! playback (now-ms)))
(set-dlna-playback-current-index! playback index) (set-dlna-playback-current-index! playback index)
(set-dlna-playback-prepared-index! playback #f) (set-dlna-playback-prepared-index! playback #f)
(prepare-next! playback))) (prepare-next! playback))))
;;; Advances to the next track or stops when the playlist has ended.
(define (advance! playback) (define (advance! playback)
(define current (dlna-playback-current-index playback)) (let* ((current (dlna-playback-current-index playback))
(define following (and (valid-index? playback current) (following (if (valid-index? playback current)
(next-index playback current))) (next-index playback current)
(if following #f)))
(play-index/locked! playback following) (if (eq? following #f)
(begin (begin
(dlna-player-stop! (dlna-playback-player playback)) (dlna-player-stop! (dlna-playback-player playback))
(notify! playback (notify! playback
'stopped 'stopped
(dlna-player-info (dlna-playback-player playback)))))) (dlna-player-info (dlna-playback-player playback))))
(play-index/locked! playback following))))
(define (poll/locked! playback) ;;; Processes one successful renderer poll while the playback lock is held.
(define info (dlna-player-info (dlna-playback-player playback))) ;;; It updates track identity, start confirmation and end-of-track handling.
(cond (define (poll-reachable/locked! playback info)
((not (dlna-info-reachable? info)) (let ((state (normalize-state (dlna-info-state info)))
(when (dlna-playback-reachable? playback) (uri (dlna-info-uri info))
(set-dlna-playback-reachable?! playback #f) (position (dlna-info-position info)))
((dlna-playback-error playback) "De DLNA-renderer is niet bereikbaar"))) (set-dlna-playback-reachable?! playback #t)
(else (when (and (string? uri)
(set-dlna-playback-reachable?! playback #t) (not (string=? uri ""))
(define state (normalize-state (dlna-info-state info))) (not (equal? uri (dlna-playback-current-uri playback))))
(define uri (dlna-info-uri info)) (set-dlna-playback-current-uri! playback uri)
(define position (dlna-info-position info)) (set-dlna-playback-stopped-polls! playback 0)
(define failed-now? #f) (update-current-track! playback info))
(when (renderer-confirms-playback? state position)
(when (and (string? uri) (set-dlna-playback-progress-seen?! playback #t))
(not (string=? uri "")) (let* ((request-ms (dlna-playback-play-request-ms playback))
(not (equal? uri (dlna-playback-current-uri playback)))) (elapsed-ms (if (eq? request-ms #f)
(set-dlna-playback-current-uri! playback uri) #f
(set-dlna-playback-stopped-polls! playback 0) (- (now-ms) request-ms)))
(update-current-track! playback info)) (failed-now?
(and (dlna-playback-playing-seen? playback)
(when (renderer-confirms-playback? state position) (not (dlna-playback-progress-seen? playback))
(set-dlna-playback-progress-seen?! playback #t)) elapsed-ms
(>= elapsed-ms playback-start-timeout-ms))))
(when (and (dlna-playback-playing-seen? playback) ;;; Handles a stopped renderer after start and progress checks complete.
(not (dlna-playback-progress-seen? playback)) (define (handle-stopped!)
(dlna-playback-play-request-ms playback) (cond
(>= (- (now-ms) ((and (not (dlna-playback-progress-seen? playback))
(dlna-playback-play-request-ms playback)) elapsed-ms
playback-start-timeout-ms)) (< elapsed-ms 5000))
(set! failed-now? #t) (void))
(warn-web-player-dlna ((not (dlna-playback-progress-seen? playback))
"DLNA start was not confirmed: state=~a position=~a uri=~a" (warn-web-player-dlna
state position (or uri "")) "DLNA renderer stopped without confirming playback: position=~a uri=~a"
(report-failure! position (or uri ""))
playback (report-failure!
"De DLNA-renderer bevestigde de start van de track niet")) playback
'dlna-renderer-no-start-of-track-confirmation))
(unless (or failed-now? (dlna-playback-failure-active? playback)) (else
(set-dlna-playback-stopped-polls!
playback
(+ 1 (dlna-playback-stopped-polls playback)))
;; Give SetNextAVTransportURI one poll to take over. Some renderers
;; need the explicit fallback on the next poll.
(when (or (eq? (dlna-playback-prepared-index playback) #f)
(> (dlna-playback-stopped-polls playback) 1))
(set-dlna-playback-playing-seen?! playback #f)
(set-dlna-playback-stopped-polls! playback 0)
(advance! playback)))))
(when failed-now?
(warn-web-player-dlna
"DLNA start was not confirmed: state=~a position=~a uri=~a"
state position (or uri ""))
(report-failure!
playback
'dlna-renderer-no-start-of-track-confirmation))
(unless (or failed-now? (dlna-playback-failure-active? playback))
(cond
((eq? state 'playing)
(set-dlna-playback-playing-seen?! playback #t)
(set-dlna-playback-stopped-polls! playback 0))
((and (eq? state 'stopped)
(dlna-playback-stop-requested? playback))
(set-dlna-playback-stop-requested?! playback #f)
(set-dlna-playback-stopped-polls! playback 0))
((and (eq? state 'stopped)
(dlna-playback-playing-seen? playback))
(handle-stopped!))))
(notify!
playback
(cond (cond
((eq? state 'playing) ((or failed-now? (dlna-playback-failure-active? playback))
(set-dlna-playback-playing-seen?! playback #t) 'stopped)
(set-dlna-playback-stopped-polls! playback 0)) ((and (dlna-playback-playing-seen? playback)
((and (eq? state 'stopped) (not (dlna-playback-progress-seen? playback)))
(dlna-playback-stop-requested? playback)) 'starting)
(set-dlna-playback-stop-requested?! playback #f) (else state))
(set-dlna-playback-stopped-polls! playback 0)) info))))
((and (eq? state 'stopped)
(dlna-playback-playing-seen? playback))
(cond
((and (not (dlna-playback-progress-seen? playback))
(dlna-playback-play-request-ms playback)
(< (- (now-ms)
(dlna-playback-play-request-ms playback))
5000))
(void))
((not (dlna-playback-progress-seen? playback))
(warn-web-player-dlna
"DLNA renderer stopped without confirming playback: position=~a uri=~a"
position (or uri ""))
(report-failure!
playback
"De DLNA-renderer bevestigde de start van de track niet"))
(else
(set-dlna-playback-stopped-polls!
playback
(+ 1 (dlna-playback-stopped-polls playback)))
;; Give SetNextAVTransportURI one poll to take over. Some
;; renderers need the explicit fallback on the following poll.
(when (or (not (dlna-playback-prepared-index playback))
(> (dlna-playback-stopped-polls playback) 1))
(set-dlna-playback-playing-seen?! playback #f)
(set-dlna-playback-stopped-polls! playback 0)
(advance! playback)))))))
(notify! ;;; Polls the renderer and reports a transition to an unreachable state once.
playback (define (poll/locked! playback)
(cond (let ((info (dlna-player-info (dlna-playback-player playback))))
((or failed-now? (dlna-playback-failure-active? playback)) 'stopped) (if (dlna-info-reachable? info)
((and (dlna-playback-playing-seen? playback) (poll-reachable/locked! playback info)
(not (dlna-playback-progress-seen? playback))) (when (dlna-playback-reachable? playback)
'starting) (set-dlna-playback-reachable?! playback #f)
(else state)) ((dlna-playback-error playback)
info)))) 'dlna-renderer-unreachable)))))
;;; Polls the renderer until playback is closed, logging recoverable failures.
(define (monitor-loop playback poll-seconds) (define (monitor-loop playback poll-seconds)
(let loop () (let loop ()
(when (dlna-playback-running? playback) (when (dlna-playback-running? playback)
@@ -286,19 +322,28 @@
(when (dlna-playback-running? playback) (when (dlna-playback-running? playback)
(with-handlers (with-handlers
((exn:fail? ((exn:fail?
(lambda (exception) (λ (exception)
(warn-web-player-dlna (warn-web-player-dlna
"Could not update DLNA playback state: ~a" "Could not update DLNA playback state: ~a"
(exn-message exception))))) (exn-message exception)))))
(with-lock playback (lambda () (poll/locked! playback)))) (with-lock playback (λ () (poll/locked! playback))))
(loop))))) (loop)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create playlist-aware playback for one network renderer. ; goal : Create playlist-aware playback for one network renderer.
; pre : Device is a media renderer, callbacks are procedures, and ; pre : Device is a media renderer, callbacks are procedures, and
; media-server is a running shared media-file-server. ; media-server is a running shared media-file-server.
; post : A DLNA player and its state-monitor thread are running. ; post : A DLNA player and its state-monitor thread are running.
; result : A playback adapter that publishes through the supplied server. ; result : A playback adapter that publishes through the supplied server.
; internals: make-dlna-player creates the renderer interface; monitor-loop polls
; it periodically. poll/locked! reconciles URI, transport state and
; position with the playlist and reports updates, failures or track
; advancement. with-lock orders polls and commands using the
; dlna-playback-lock accessor generated for the struct's lock field.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-dlna-playback device (define (make-dlna-playback device
tracks tracks
@@ -306,39 +351,66 @@
error error
#:media-file-server media-server #:media-file-server media-server
#:poll-seconds [poll-seconds 1]) #:poll-seconds [poll-seconds 1])
(define raw (let* ((raw (make-dlna-player device
(make-dlna-player device #:media-file-server media-server))
#:media-file-server media-server)) (playback
(define playback (dlna-playback raw tracks update error 'off #f #f #f
(dlna-playback raw tracks update error 'off #f #f #f #f #f #f #f 0 #f #t #t #f
#f #f #f #f 0 #f #t #t #f (make-semaphore 1))))
(make-semaphore 1))) (set-dlna-playback-monitor!
(set-dlna-playback-monitor! playback
playback (thread (λ () (monitor-loop playback poll-seconds))))
(thread (λ () (monitor-loop playback poll-seconds)))) playback))
playback)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Start the track at index in the current playlist.
; pre : Playback is open and index identifies an existing track.
; post : The renderer starts the track and the next track is prepared.
; result : The result of the synchronized playback operation.
; internals: Playback state changes and callbacks run while holding the lock.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-play-index! playback index) (define (dlna-playback-play-index! playback index)
(with-lock playback (lambda () (play-index/locked! playback index)))) (with-lock playback (λ () (play-index/locked! playback index))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Pause the current renderer transport.
; pre : Playback is open and the renderer accepts pause requests.
; post : The renderer is paused and listeners receive the new state.
; result : The result of the synchronized playback operation.
; internals: The renderer is queried immediately after the pause request.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-pause! playback) (define (dlna-playback-pause! playback)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-pause! (dlna-playback-player playback)) (dlna-player-pause! (dlna-playback-player playback))
(notify! playback 'paused (dlna-player-info (dlna-playback-player playback)))))) (notify! playback 'paused (dlna-player-info (dlna-playback-player playback))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resume the paused renderer transport.
; pre : Playback is open and the renderer accepts resume requests.
; post : The renderer is playing and listeners receive the new state.
; result : The result of the synchronized playback operation.
; internals: The renderer is queried immediately after the resume request.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-resume! playback) (define (dlna-playback-resume! playback)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-resume! (dlna-playback-player playback)) (dlna-player-resume! (dlna-playback-player playback))
(notify! playback 'playing (dlna-player-info (dlna-playback-player playback)))))) (notify! playback 'playing (dlna-player-info (dlna-playback-player playback))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Stop the current renderer transport.
; pre : Playback is open.
; post : Pending start and failure state is cleared and listeners see stopped.
; result : The result of the synchronized playback operation.
; internals: stop-requested? distinguishes this stop from a finished track.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-stop! playback) (define (dlna-playback-stop! playback)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(set-dlna-playback-stop-requested?! playback #t) (set-dlna-playback-stop-requested?! playback #t)
(set-dlna-playback-playing-seen?! playback #f) (set-dlna-playback-playing-seen?! playback #f)
(set-dlna-playback-progress-seen?! playback #f) (set-dlna-playback-progress-seen?! playback #f)
@@ -348,47 +420,79 @@
(dlna-player-stop! (dlna-playback-player playback)) (dlna-player-stop! (dlna-playback-player playback))
(notify! playback 'stopped (dlna-player-info (dlna-playback-player playback)))))) (notify! playback 'stopped (dlna-player-info (dlna-playback-player playback))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Seek to a percentage of the current track.
; pre : Playback is open and percentage is accepted by the DLNA player.
; post : The renderer position and listener state reflect the requested seek.
; result : The result of the synchronized playback operation.
; internals: The synchronously refreshed DLNA cache is published immediately.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-seek-percentage! playback percentage) (define (dlna-playback-seek-percentage! playback percentage)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-seek-percentage! (dlna-playback-player playback) percentage) (dlna-player-seek-percentage! (dlna-playback-player playback) percentage)
;; racket-audio-dlna updates its cache synchronously after Seek. Publish ;; racket-audio-dlna updates its cache synchronously after Seek. Publish
;; that value immediately so the web slider does not jump back. ;; that value immediately so the web slider does not jump back.
(define info (dlna-player-info (dlna-playback-player playback))) (let ((info (dlna-player-info (dlna-playback-player playback))))
(notify! playback (notify! playback
(normalize-state (dlna-info-state info)) (normalize-state (dlna-info-state info))
info)))) info)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Set the renderer volume to a percentage.
; pre : Playback is open and percentage is accepted by the DLNA player.
; post : The renderer volume and listener state reflect the requested value.
; result : The result of the synchronized playback operation.
; internals: The renderer is queried immediately after changing the volume.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-volume! playback percentage) (define (dlna-playback-volume! playback percentage)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-volume! (dlna-playback-player playback) percentage) (dlna-player-volume! (dlna-playback-player playback) percentage)
(define info (dlna-player-info (dlna-playback-player playback))) (let ((info (dlna-player-info (dlna-playback-player playback))))
(notify! playback (notify! playback
(normalize-state (dlna-info-state info)) (normalize-state (dlna-info-state info))
info)))) info)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Change playlist repeat behavior.
; pre : Playback is open and repeat is 'off, 'one or 'all.
; post : The next prepared track reflects the new repeat behavior.
; result : The result of the synchronized playback operation.
; internals: Any previously prepared index is discarded before recalculation.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-repeat! playback repeat) (define (dlna-playback-repeat! playback repeat)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(set-dlna-playback-repeat! playback repeat) (set-dlna-playback-repeat! playback repeat)
(set-dlna-playback-prepared-index! playback #f) (set-dlna-playback-prepared-index! playback #f)
(prepare-next! playback)))) (prepare-next! playback))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Close playback and release its renderer resources.
; pre : Playback was created by make-dlna-playback.
; post : The monitor has stopped and the underlying DLNA player is closed.
; result : Void.
; internals: The running flag prevents repeated closure of the same player.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dlna-playback-close! playback) (define (dlna-playback-close! playback)
(when (dlna-playback-running? playback) (when (dlna-playback-running? playback)
(set-dlna-playback-running?! playback #f) (set-dlna-playback-running?! playback #f)
(define monitor (dlna-playback-monitor playback)) (let ((monitor (dlna-playback-monitor playback)))
(when (and monitor (not (thread-dead? monitor))) (when (and monitor (not (thread-dead? monitor)))
(kill-thread monitor)) (kill-thread monitor))
(set-dlna-playback-monitor! playback #f) (set-dlna-playback-monitor! playback #f)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-close! (dlna-playback-player playback)))))) (dlna-player-close! (dlna-playback-player playback)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module dlna-playback.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test (module+ test
(require rackunit) (require rackunit)
@@ -400,7 +504,7 @@
(track (build-path "music" "02.flac") (track (build-path "music" "02.flac")
"Second" "Artist" "Album" 60 "audio/flac")) "Second" "Artist" "Album" 60 "audio/flac"))
(define playback (define playback
(dlna-playback #f (lambda () (list first second)) void void (dlna-playback #f (λ () (list first second)) void void
'off 0 #f #f #f #f #f #f 0 #f #t #f #f 'off 0 #f #f #f #f #f #f 0 #f #t #f #f
(make-semaphore 1))) (make-semaphore 1)))
@@ -411,17 +515,21 @@
(set-dlna-playback-repeat! playback 'one) (set-dlna-playback-repeat! playback 'one)
(check-equal? (next-index playback 1) 1) (check-equal? (next-index playback 1) 1)
(set-dlna-playback-prepared-index! playback 1) (let ((second-info
(check-equal? (dlna-info
(track-index-for-info 'playing
playback (dlna-track-info (track-file second) "Second" "Artist" "Album"
(dlna-info #f #f #f 60 #f #f #f)
'playing "http://renderer.test/02.flac"
(dlna-track-info (track-file second) "Second" "Artist" "Album" #f #f 1 60 25 #f #t)))
#f #f #f 60 #f #f #f) (set-dlna-playback-prepared-index! playback 1)
"http://renderer.test/02.flac" (check-equal? (track-index-for-info playback second-info) 1)
#f #f 1 60 25 #f #t)) (set-dlna-playback-prepared-index! playback #f)
1) (check-equal? (track-index-for-info playback second-info) 1)
(check-false
(track-index-for-info
playback
(struct-copy dlna-info second-info (track #f)))))
(check-eq? (normalize-state 'transitioning) 'starting) (check-eq? (normalize-state 'transitioning) 'starting)
(check-eq? (normalize-state 'no-media) 'stopped) (check-eq? (normalize-state 'no-media) 'stopped)
(check-true (renderer-confirms-playback? 'playing #f)) (check-true (renderer-confirms-playback? 'playing #f))
+235 -106
View File
@@ -45,19 +45,25 @@
"folder.jpg" "folder.jpeg" "folder.png" "folder.jpg" "folder.jpeg" "folder.png"
"front.jpg" "front.jpeg" "front.png")) "front.jpg" "front.jpeg" "front.png"))
;;; Checks whether a path has an extension supported by racket-audio.
(define (audio-file? file) (define (audio-file? file)
(let ((extension (path-get-extension file))) (let ((extension (path-get-extension file)))
(and extension (if (eq? extension #f)
(member (string-downcase #f
(string-trim (let ((extension-name
(bytes->string/utf-8 extension) (string-downcase
".")) (string-trim
supported-extensions) (bytes->string/utf-8 extension)
#t))) "."))))
(if (member extension-name supported-extensions)
#t
#f)))))
;;; Checks whether the final path element starts with a dot.
(define (hidden-name? path) (define (hidden-name? path)
(string-prefix? (path->string path) ".")) (string-prefix? (path->string path) "."))
;;; Derives a fallback track title from the file name without its extension.
(define (file-title file) (define (file-title file)
(let* ((name (file-name-from-path file)) (let* ((name (file-name-from-path file))
(without-extension (without-extension
@@ -66,12 +72,15 @@
file))) file)))
(path->string without-extension))) (path->string without-extension)))
;;; Returns a non-empty string value or the supplied fallback.
(define (nonempty value fallback) (define (nonempty value fallback)
(if (and (string? value) (if (and (string? value)
(not (string=? (string-trim value) ""))) (not (string=? (string-trim value) "")))
value value
fallback)) fallback))
;;; Reads audio metadata and converts a file path to a track value.
;;; File-name and MIME-type fallbacks are used when metadata cannot be read.
(define (path->track file) (define (path->track file)
(let ((fallback-title (file-title file))) (let ((fallback-title (file-title file)))
(with-handlers (with-handlers
@@ -95,6 +104,7 @@
(track file fallback-title "" "" #f (track file fallback-title "" "" #f
(mimetype-for-ext file)))))))) (mimetype-for-ext file))))))))
;;; Builds the filesystem path represented by a library-relative path.
(define (library-path library relative-path) (define (library-path library relative-path)
(if (null? relative-path) (if (null? relative-path)
(music-library-root library) (music-library-root library)
@@ -102,6 +112,7 @@
(music-library-root library) (music-library-root library)
relative-path))) relative-path)))
;;; Classifies a path as a container, supported track or unusable entry.
(define (path-kind path) (define (path-kind path)
(cond (cond
((directory-exists? path) 'container) ((directory-exists? path) 'container)
@@ -110,6 +121,7 @@
'track) 'track)
(else #f))) (else #f)))
;;; Orders browser entries with containers first and names alphabetically.
(define (entry<? first second) (define (entry<? first second)
(cond (cond
((and (eq? (browser-entry-kind first) 'container) ((and (eq? (browser-entry-kind first) 'container)
@@ -122,6 +134,7 @@
(string-ci<? (browser-entry-name first) (string-ci<? (browser-entry-name first)
(browser-entry-name second))))) (browser-entry-name second)))))
;;; Recursively converts the browsable contents of a directory to tracks.
(define (directory-tracks library relative-path) (define (directory-tracks library relative-path)
(append-map (append-map
(λ (entry) (λ (entry)
@@ -134,126 +147,196 @@
(browser-entry-relative-path entry)))))) (browser-entry-relative-path entry))))))
(browse-library library relative-path))) (browse-library library relative-path)))
(define (library-contains-audio-file? libraries file) ;;; Produces a resolved complete path, or #f when resolution fails.
(and (path-string? file) (define (complete-path/safe path)
(file-exists? file) (with-handlers ((exn:fail? (λ (_) #f)))
(audio-file? file) (simplify-path (path->complete-path path) #t)))
(let ((full-file
(with-handlers ((exn:fail? (lambda (_) #f))) ;;; Checks whether file is located below root without traversing upward.
(simplify-path (path->complete-path file) #t)))) (define (path-below-root? root file)
(and full-file (let* ((relative (find-relative-path root file))
(for/or ((library (in-list libraries))) (elements (explode-path relative)))
(define root (and (relative-path? relative)
(with-handlers ((exn:fail? (lambda (_) #f))) (not (member 'up elements)))))
(simplify-path
(path->complete-path (music-library-root library)) ;;; Recognizes a library specification containing a display name and path.
#t))) (define (named-library-specification? specification)
(and root (and (list? specification)
(let ((relative (find-relative-path root full-file))) (= (length specification) 2)
(and (relative-path? relative) (string? (car specification))
(not (member 'up (explode-path relative))))))))))) (path-string? (cadr specification))))
;;; Extracts the optional display name and path from a library specification.
(define (specification-values specification)
(cond
((named-library-specification? specification)
(values (string-trim (car specification))
(cadr specification)))
((path-string? specification)
(values #f specification))
(else
(raise-argument-error
'make-music-libraries
"(or/c path-string? (list/c string? path-string?))"
specification))))
;;; Reads embedded ID3 artwork from a track, returning #f when unavailable.
(define (embedded-artwork item)
(with-handlers ((exn:fail? (λ (_) #f)))
(call-with-id3-tags
(track-file item)
(λ (tags)
(if (not (tags-valid? tags))
#f
(let ((picture (tags-picture tags)))
(if (eq? picture #f)
#f
(let ((mime (id3-picture-mimetype picture)))
(artwork
(if (and (string? mime)
(not (string=? mime "")))
mime
"application/octet-stream")
(id3-picture-bytes picture))))))))))
;;; Checks whether a path names an existing conventional cover image.
(define (cover-file? candidate)
(let ((name (file-name-from-path candidate)))
(cond
((eq? name #f) #f)
((not (file-exists? candidate)) #f)
((member (path->string name)
cover-file-names
string-ci=?) #t)
(else #f))))
;;; Searches the track directory for a conventional cover image.
(define (cover-artwork item)
(with-handlers ((exn:fail? (λ (_) #f)))
(let* ((track-directory (path-only (track-file item)))
(directory (if (eq? track-directory #f)
(current-directory)
track-directory))
(cover (findf cover-file?
(directory-list directory #:build? #t))))
(if (eq? cover #f)
#f
(let ((mime (mimetype-for-ext cover)))
(artwork (if (string? mime)
mime
"application/octet-stream")
(file->bytes cover)))))))
;;; Validates one normalized library root and constructs its public value.
(define (named-root->music-library named-root index)
(let ((configured-name (car named-root))
(root (cadr named-root)))
(unless (directory-exists? root)
(raise-arguments-error
'make-music-libraries
"music library is not an existing directory"
"path" root))
(let* ((name (file-name-from-path root))
(default-name (if (eq? name #f)
(path->string root)
(path->string name))))
(music-library
(format "library-~a" index)
(cond
((eq? configured-name #f) default-name)
((string=? configured-name "") default-name)
(else configured-name))
root))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions ;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check whether a supported audio file belongs to a music library.
; pre : Libraries contains music-library values; file may be any value.
; post : The file system remains unchanged.
; result : #t when file exists below a configured root, otherwise #f.
; internals: audio-file? first rejects unsupported files. complete-path/safe
; resolves the candidate and each library root. The named loop calls
; path-below-root? until one root contains the file; that helper uses
; find-relative-path and rejects paths containing an 'up element.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (library-contains-audio-file? libraries file)
(cond
((not (path-string? file)) #f)
((not (file-exists? file)) #f)
((not (audio-file? file)) #f)
(else
(let ((full-file (complete-path/safe file)))
(if (eq? full-file #f)
#f
(let loop ((remaining libraries))
(if (null? remaining)
#f
(let ((root
(complete-path/safe
(music-library-root (car remaining)))))
(cond
((eq? root #f)
(loop (cdr remaining)))
((path-below-root? root full-file) #t)
(else
(loop (cdr remaining))))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Turn configured directory paths into music libraries. ; goal : Turn configured directory paths into music libraries.
; pre : Every value is a path or a (display-name path) list. ; pre : Every value is a path or a (display-name path) list.
; post : No directory contents or audio metadata have been read. ; post : No directory contents or audio metadata have been read.
; result : Libraries in configuration order, without duplicate roots. ; result : Libraries in configuration order, without duplicate roots.
; internals: specification-values separates each optional name from its path.
; map normalizes the paths and remove-duplicates compares their
; roots. The named loop calls named-root->music-library to validate
; each directory and assign its sequential library id.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-music-libraries specifications) (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 (let ((roots
(remove-duplicates (remove-duplicates
(for/list ((specification (in-list specifications))) (map (λ (specification)
(let-values (((name path) (let-values (((name path)
(specification-values specification))) (specification-values specification)))
(list name (list name
(normal-case-path (normal-case-path
(path->complete-path path))))) (path->complete-path path)))))
(lambda (first second) specifications)
(λ (first second)
(equal? (cadr first) (cadr second)))))) (equal? (cadr first) (cadr second))))))
(for/list ((named-root (in-list roots)) (let loop ((remaining roots)
(index (in-naturals))) (index 0))
(define configured-name (car named-root)) (if (null? remaining)
(define root (cadr named-root)) '()
(unless (directory-exists? root) (cons (named-root->music-library (car remaining) index)
(raise-arguments-error (loop (cdr remaining) (add1 index)))))))
'make-music-libraries
"music library is not an existing directory"
"path" root))
(let ((name (file-name-from-path root)))
(music-library
(format "library-~a" index)
(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. ; goal : Read the artwork associated with a track.
; pre : Item names a local audio file. ; pre : Item names a local audio file.
; post : The audio file and optional neighbouring image remain unchanged. ; post : The audio file and optional neighbouring image remain unchanged.
; result : Embedded artwork, a conventional folder cover, or #f. ; result : Embedded artwork, a conventional folder cover, or #f.
; internals: embedded-artwork first reads the picture stored in the audio tags.
; Only when that returns #f does cover-artwork search the track's
; directory for one of the names in cover-file-names.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (track-artwork item) (define (track-artwork item)
(define embedded (let ((embedded (embedded-artwork item)))
(with-handlers ((exn:fail? (λ (_) #f))) (if (eq? embedded #f)
(call-with-id3-tags (cover-artwork item)
(track-file item) embedded)))
(λ (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. ; goal : List the immediate folders and supported audio files in a library.
; pre : Relative-path was produced by a previous browse result. ; pre : Relative-path was produced by a previous browse result.
; post : Child directories are listed before tracks; metadata is not read. ; post : Child directories are listed before tracks; metadata is not read.
; result : Browser entries for one directory level. ; result : Browser entries for one directory level.
; internals: library-path resolves the requested directory. directory-list and
; path-kind supply filter-map with usable children; hidden-name?
; removes hidden containers. sort uses entry<? to put containers
; first and compare names without regard to case.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (browse-library library relative-path) (define (browse-library library relative-path)
(let ((path (library-path library relative-path))) (let ((path (library-path library relative-path)))
@@ -267,13 +350,20 @@
(λ (name) (λ (name)
(let* ((full-path (build-path path name)) (let* ((full-path (build-path path name))
(kind (path-kind full-path))) (kind (path-kind full-path)))
(and kind (cond
(not (and (eq? kind 'container) ((eq? kind #f) #f)
(hidden-name? name))) ((eq? kind 'container)
(browser-entry (if (hidden-name? name)
(path->string name) #f
kind (browser-entry
(append relative-path (list name)))))) (path->string name)
kind
(append relative-path (list name)))))
(else
(browser-entry
(path->string name)
kind
(append relative-path (list name)))))))
(directory-list path)) (directory-list path))
entry<?))) entry<?)))
@@ -282,6 +372,9 @@
; pre : Entry belongs to library and was produced by browse-library. ; pre : Entry belongs to library and was produced by browse-library.
; post : Track metadata is read; containers are traversed recursively. ; post : Track metadata is read; containers are traversed recursively.
; result : One track, or all supported tracks below the selected container. ; result : One track, or all supported tracks below the selected container.
; internals: A track entry is resolved by library-path and read by path->track.
; A container is passed to directory-tracks, which recursively calls
; browse-library and path->track in browser sort order.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (browser-entry->tracks library entry) (define (browser-entry->tracks library entry)
(if (eq? (browser-entry-kind entry) 'container) (if (eq? (browser-entry-kind entry) 'container)
@@ -292,18 +385,30 @@
(library-path library (library-path library
(browser-entry-relative-path entry)))))) (browser-entry-relative-path entry))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module library.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test (module+ test
(require rackunit) (require rackunit)
(define root (define root
(make-temporary-file "rkt-web-library-~a" 'directory)) (make-temporary-file "rkt-web-library-~a" 'directory))
(define outside-file
(make-temporary-file "rkt-web-outside-~a.mp3"))
(dynamic-wind (dynamic-wind
void void
(λ () (λ ()
(make-directory (build-path root "Album")) (make-directory (build-path root "Album"))
(make-directory (build-path root ".Hidden"))
(call-with-output-file
(build-path root "Album" "inside.mp3") void)
(call-with-output-file (build-path root "track.mp3") void) (call-with-output-file (build-path root "track.mp3") void)
(call-with-output-file (build-path root "cover.jpg") void) (call-with-output-file (build-path root "cover.jpg") void)
(call-with-output-file (build-path root "ignored.txt") void)
(let* ((libraries (make-music-libraries (list root))) (let* ((libraries (make-music-libraries (list root)))
(entries (browse-library (car libraries) '()))) (entries (browse-library (car libraries) '())))
(check-equal? (length libraries) 1) (check-equal? (length libraries) 1)
@@ -312,6 +417,29 @@
(check-eq? (browser-entry-kind (car entries)) 'container) (check-eq? (browser-entry-kind (car entries)) 'container)
(check-equal? (browser-entry-name (cadr entries)) "track.mp3") (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?
(length
(browser-entry->tracks (car libraries) (car entries)))
1)
(check-true
(library-contains-audio-file?
libraries
(build-path root "track.mp3")))
(check-true
(library-contains-audio-file?
libraries
(build-path root "Album" "inside.mp3")))
(check-false
(library-contains-audio-file?
libraries
(build-path root "cover.jpg")))
(check-false
(library-contains-audio-file?
libraries
outside-file))
(check-equal?
(length (make-music-libraries (list root root)))
1)
(check-equal? (check-equal?
(music-library-name (music-library-name
(car (make-music-libraries (car (make-music-libraries
@@ -324,4 +452,5 @@
"Track" "" "" #f "audio/mpeg"))) "Track" "" "" #f "audio/mpeg")))
"image/jpeg"))) "image/jpeg")))
(λ () (λ ()
(delete-directory/files root)))) (delete-directory/files root)
(delete-file outside-file))))
-69
View File
@@ -1,69 +0,0 @@
#lang racket/base
(require file/sha1
racket/os
racket/path
racket/random
racket/string
simple-ini)
(provide (struct-out player-agent-config)
load-player-agent-config
save-player-agent-config!
valid-app-id?)
(struct player-agent-config (file ini app-id server-url name) #:transparent)
(define (fresh-app-id)
(bytes->hex-string (crypto-random-bytes 32)))
(define (valid-app-id? value)
(and (string? value)
(regexp-match? #px"^[0-9a-fA-F]{64}$" value)))
(define (load-player-agent-config [file (get-ini-file 'rkt-web-player-agent)])
(define ini (file->ini file))
(define configured-id (ini-get ini 'agent 'app-id #f))
(define value
(player-agent-config
file
ini
(if (valid-app-id? configured-id)
(string-downcase configured-id)
(fresh-app-id))
(ini-get ini 'server 'url "http://127.0.0.1:8080")
(ini-get ini 'agent 'name
(format "~a playback" (gethostname)))))
(save-player-agent-config! value)
value)
(define (save-player-agent-config! value)
(define ini (player-agent-config-ini value))
(ini-set! ini 'agent 'app-id (player-agent-config-app-id value))
(ini-set! ini 'agent 'name (player-agent-config-name value))
(ini-set! ini 'server 'url (player-agent-config-server-url value))
(ini->file ini (player-agent-config-file value) #:private? #t))
(module+ test
(require rackunit
racket/file)
(define test-directory (make-temporary-file "rkt-agent-config-~a" 'directory))
(define test-file (build-path test-directory "agent.ini"))
(dynamic-wind
void
(lambda ()
(define first (load-player-agent-config test-file))
(check-true (valid-app-id? (player-agent-config-app-id first)))
(define changed
(struct-copy player-agent-config first
(server-url "https://music.example.test")
(name "Test output")))
(save-player-agent-config! changed)
(define second (load-player-agent-config test-file))
(check-equal? (player-agent-config-app-id second)
(player-agent-config-app-id first))
(check-equal? (player-agent-config-server-url second)
"https://music.example.test")
(check-equal? (player-agent-config-name second) "Test output"))
(lambda () (delete-directory/files test-directory))))
-425
View File
@@ -1,425 +0,0 @@
#lang racket/base
(require json
net/url
racket-audio
racket/file
racket/path
racket/port
racket/string
simple-log
"translate.rkt")
(provide (struct-out player-agent-runtime)
make-player-agent-runtime)
(sl-def-log player-agent)
(struct exn:fail:agent-denied exn:fail () #:transparent)
(struct player-agent-runtime
(start! reconnect! shutdown! snapshot current-track running? app-id)
#:transparent)
(define (base-url value)
(string->url
(regexp-replace #px"/+$" (string-trim value) "")))
(define (endpoint-url base path)
(combine-url/relative (base-url base) path))
(define (post-json base path data)
(define input
(post-pure-port
(endpoint-url base path)
(jsexpr->bytes data)
(list "Content-Type: application/json"
"Cache-Control: no-store")))
(dynamic-wind
void
(lambda ()
(define response (read-json input))
(when (and (hash? response)
(string? (hash-ref response 'error #f)))
(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)
(lambda () (close-input-port input))))
(define (normal-state state)
(cond
((memq state '(initialized no-media)) "stopped")
((eq? state 'transitioning) "starting")
(else (symbol->string state))))
(define (safe-delete-file file)
(when (and file (file-exists? file))
(with-handlers ((exn:fail?
(lambda (exception)
(warn-player-agent
"Could not remove temporary media file ~a: ~a"
file
(exn-message exception)))))
(delete-file file))))
(define (make-player-agent-runtime initial-server-url
initial-name
app-id
#:status-callback
[status-callback void]
#:denied-callback
[denied-callback void])
(define server-url initial-server-url)
(define assigned-name initial-name)
(define state-lock (make-semaphore 1))
(define worker #f)
(define command-worker #f)
(define executing-command-id 0)
(define running #f)
(define authorization-notified? #f)
(define audio #f)
(define current-media-key #f)
(define cached-media (make-hash))
(define prefetched-track #f)
(define auto-started-key #f)
(define pending-auto-music-id #f)
(define music-tracks (make-hash))
(define current-track-value #f)
(define acknowledged-command 0)
(define ended-counter 0)
(define logical-volume 50)
(define agent-state
(hasheq 'state "stopped"
'position 0
'duration 'null
'rate 'null
'channels 'null
'bits 'null
'format ""
'volume logical-volume
'error 'null))
(define (with-agent-state proc)
(call-with-semaphore state-lock proc))
(define (state-value value fallback)
(if (eq? value #f) fallback value))
(define (snapshot)
(with-agent-state (lambda () agent-state)))
(define (current-track)
(with-agent-state (lambda () current-track-value)))
(define (set-agent-error! message)
(with-agent-state
(lambda ()
(set! agent-state (hash-set agent-state 'error message)))))
(define (clear-agent-error!)
(with-agent-state
(lambda ()
(set! agent-state (hash-set agent-state 'error 'null)))))
(define (update-from-audio! state full-state)
(with-agent-state
(lambda ()
(define audible-music-id (hash-ref full-state 'at-music-id #f))
(set! agent-state
(hasheq
'state (normal-state state)
'position (state-value (hash-ref full-state 'at-second #f) 0)
'duration (state-value (hash-ref full-state 'duration #f) 'null)
'rate (state-value (hash-ref full-state 'rate #f) 'null)
'channels (state-value (hash-ref full-state 'channels #f) 'null)
'bits (state-value (hash-ref full-state 'bits #f) 'null)
'format (let ((decoder (hash-ref full-state 'decoder #f)))
(if decoder (format "~a" decoder) ""))
'volume logical-volume
'error 'null))
(when (and pending-auto-music-id
(number? audible-music-id)
(= pending-auto-music-id audible-music-id))
(define audible-track
(hash-ref music-tracks audible-music-id #f))
(when audible-track
(set! current-track-value audible-track)
(hash-clear! music-tracks)
(hash-set! music-tracks audible-music-id audible-track))
(set! pending-auto-music-id #f)
(set! ended-counter (+ ended-counter 1))))))
(define (ensure-audio!)
(unless audio
(set! audio
(make-audio-player
(lambda (_handle state full-state)
(update-from-audio! state full-state))
(lambda (handle)
(advance-at-decoder-eof! handle))))
(audio-ao-buf-ms! audio 500)
(audio-buf-seconds! audio 4 10)
(define scaled (/ logical-volume 100.0))
(audio-volume! audio (* 100.0 scaled scaled)))
audio)
(define (download-media! token filename)
(define extension
(or (path-get-extension (string->path filename)) #""))
(define target
(make-temporary-file
(string-append "rkt-player-agent-~a"
(bytes->string/utf-8 extension))))
(define path (format "/api/agent/media/~a/~a" app-id token))
(define input (get-pure-port (endpoint-url server-url path)))
(with-handlers ((exn:fail?
(lambda (exception)
(close-input-port input)
(safe-delete-file target)
(raise exception))))
(call-with-output-file
target
(lambda (output) (copy-port input output))
#:exists 'truncate/replace)
(close-input-port input)
target))
(define (command-cache-key data)
(hash-ref data 'cacheKey (hash-ref data 'mediaToken)))
(define (ensure-media-cached! data)
(define key (command-cache-key data))
(define found (hash-ref cached-media key #f))
(if (and found (file-exists? found))
found
(let ((downloaded
(download-media!
(hash-ref data 'mediaToken)
(hash-ref data 'filename "track"))))
(hash-set! cached-media key downloaded)
downloaded)))
(define (discard-unused-media! keep-key)
(for ((entry (in-list (hash->list cached-media))))
(unless (equal? (car entry) keep-key)
(safe-delete-file (cdr entry))
(hash-remove! cached-media (car entry)))))
;; Decoder EOF occurs before audible EOF. Queueing the prefetched decoder at
;; this point appends it behind racket-audio's remaining output buffer.
(define (advance-at-decoder-eof! handle)
(define prepared
(with-agent-state
(lambda ()
(define value prefetched-track)
(set! prefetched-track #f)
value)))
(cond
(prepared
(define data (car prepared))
(define path (cdr prepared))
(define key (command-cache-key data))
(with-handlers
((exn:fail?
(lambda (exception)
(warn-player-agent "Could not start prefetched track: ~a"
(exn-message exception))
(set-agent-error! (exn-message exception))
(with-agent-state
(lambda () (set! ended-counter (+ ended-counter 1)))))))
(define music-id (audio-play! handle path))
(info-player-agent "Queued prefetched track ~a as music id ~a"
(hash-ref data 'filename "track")
music-id)
(set! current-media-key key)
(discard-unused-media! key)
(with-agent-state
(lambda ()
(hash-set! music-tracks music-id data)
(set! auto-started-key key)
(set! pending-auto-music-id music-id)))))
(else
(warn-player-agent
"Decoder reached EOF before the next track was prefetched")
(with-agent-state
(lambda () (set! ended-counter (+ ended-counter 1)))))))
(define (execute-command! command)
(define action (hash-ref command 'action ""))
(define data (hash-ref command 'data (hasheq)))
(info-player-agent "Executing command ~a" action)
(cond
((string=? action "play")
(define next-key (command-cache-key data))
(define already-started?
(with-agent-state
(lambda ()
(define matches?
(and auto-started-key (equal? auto-started-key next-key)))
(when matches? (set! auto-started-key #f))
matches?)))
(with-agent-state
(lambda () (set! current-track-value data)))
(unless already-started?
(with-agent-state
(lambda ()
(set! prefetched-track #f)
(set! auto-started-key #f)
(set! pending-auto-music-id #f)
(set! agent-state
(hash-set
(hash-set agent-state 'state "starting")
'error 'null))))
(define next-media (ensure-media-cached! data))
;; audio-play! interrupts and closes the previous decoder itself.
(define music-id (audio-play! (ensure-audio!) next-media))
(with-agent-state
(lambda ()
(hash-clear! music-tracks)
(hash-set! music-tracks music-id data)))
(set! current-media-key next-key)
(discard-unused-media! next-key)))
((string=? action "prefetch")
(define key (command-cache-key data))
(define path (ensure-media-cached! data))
(with-agent-state
(lambda () (set! prefetched-track (cons data path))))
(info-player-agent "Prefetched ~a" (hash-ref data 'filename "track"))
(for ((entry (in-list (hash->list cached-media))))
(unless (or (equal? (car entry) current-media-key)
(equal? (car entry) key))
(safe-delete-file (cdr entry))
(hash-remove! cached-media (car entry)))))
((string=? action "pause")
(audio-pause! (ensure-audio!) #t))
((string=? action "resume")
(audio-pause! (ensure-audio!) #f))
((string=? action "stop")
(with-agent-state
(lambda ()
(set! prefetched-track #f)
(set! auto-started-key #f)
(set! pending-auto-music-id #f)))
(when audio (audio-stop! audio)))
((string=? action "seek")
(audio-seek! (ensure-audio!) (hash-ref data 'percentage 0)))
((string=? action "volume")
(set! logical-volume (min 100 (max 0 (hash-ref data 'value 50))))
(define scaled (/ logical-volume 100.0))
(audio-volume! (ensure-audio!) (* 100.0 scaled scaled))
(with-agent-state
(lambda ()
(set! agent-state
(hash-set agent-state 'volume logical-volume)))))
(else
(error 'player-agent "unknown command: ~a" action))))
(define (poll-loop)
(with-handlers
((exn:fail:agent-denied?
(lambda (exception)
(define message (format (tr 'denied-message) app-id))
(warn-player-agent "Agent authorization refused: ~a"
(exn-message exception))
(set-agent-error! message)
(status-callback
(tr 'unauthorized-status))
(unless authorization-notified?
(set! authorization-notified? #t)
(denied-callback message))
(when running
(sleep 3)
(poll-loop))))
(exn:fail?
(lambda (exception)
(warn-player-agent "Connection cycle failed: ~a"
(exn-message exception))
(set-agent-error! (exn-message exception))
(status-callback
(format (tr 'disconnected) (exn-message exception)))
(when running
(sleep 3)
(poll-loop)))))
(post-json server-url
"/api/agent/register"
(hasheq 'appId app-id 'name assigned-name))
(clear-agent-error!)
(status-callback (tr 'connected))
(info-player-agent "Registered at ~a as ~a" server-url assigned-name)
(let loop ()
(when running
(define response
(post-json
server-url
"/api/agent/poll"
(hasheq 'appId app-id
'name assigned-name
'ack acknowledged-command
'endedCounter ended-counter
'state (snapshot))))
(define command (hash-ref response 'command 'null))
(when (and (hash? command)
(> (hash-ref command 'id 0) acknowledged-command)
(not (= (hash-ref command 'id 0) executing-command-id)))
(set! executing-command-id (hash-ref command 'id))
(set! command-worker
(thread
(lambda ()
(with-handlers
((exn:fail?
(lambda (exception)
(warn-player-agent "Command failed: ~a"
(exn-message exception))
(set-agent-error! (exn-message exception)))))
(clear-agent-error!)
(execute-command! command))
(set! acknowledged-command (hash-ref command 'id))
(set! executing-command-id 0)
(set! command-worker #f)))))
(sleep 1)
(loop)))))
(define (start!)
(unless running
(set! running #t)
(status-callback (tr 'connecting))
(set! worker (thread poll-loop))))
(define (stop!)
(set! running #f)
(when (and worker (not (thread-dead? worker)))
(kill-thread worker))
(when (and command-worker (not (thread-dead? command-worker)))
(kill-thread command-worker))
(set! worker #f)
(set! command-worker #f)
(set! executing-command-id 0))
(define (reconnect! new-server-url new-name)
(stop!)
(set! authorization-notified? #f)
(set! server-url (string-trim new-server-url))
(set! assigned-name (string-trim new-name))
(start!))
(define (shutdown!)
(stop!)
(when audio
(with-handlers ((exn:fail? void))
(audio-quit! audio))
(set! audio #f))
(for ((path (in-hash-values cached-media)))
(safe-delete-file path))
(hash-clear! cached-media))
(player-agent-runtime start!
reconnect!
shutdown!
snapshot
current-track
(lambda () running)
app-id))
-275
View File
@@ -1,275 +0,0 @@
#lang racket/base
(require racket/class
racket/format
racket/gui/base
racket/os
racket/path
racket/string
simple-log
"player-agent-config.rkt"
"player-agent-core.rkt"
"player-agent-tray.rkt"
"translate.rkt")
(provide run-player-agent-gui)
(sl-def-log player-agent-gui)
(define log-file
(build-path (find-system-path 'pref-dir)
"rkt-web-player-agent.log"))
(define (input-field label init-value panel)
(define field
(new text-field%
(parent panel)
(label label)
(init-value init-value)))
(send (send field get-editor) set-padding 0 2 0 2)
field)
(define (format-time value)
(define seconds
(if (and (number? value) (>= value 0))
(inexact->exact (floor value))
0))
(define hours (quotient seconds 3600))
(define minutes (quotient (remainder seconds 3600) 60))
(define remaining (remainder seconds 60))
(format "~a:~a:~a"
(~r hours #:min-width 2 #:pad-string "0")
(~r minutes #:min-width 2 #:pad-string "0")
(~r remaining #:min-width 2 #:pad-string "0")))
(define (run-player-agent-gui)
(sl-log-to-file log-file)
(define config (load-player-agent-config))
(define frame #f)
(define runtime #f)
(define status-message #f)
(define playback-message #f)
(define playback-details #f)
(define playback-filename #f)
(define name-field #f)
(define server-field #f)
(define connect-button #f)
(define playback-timer #f)
(define tray-timer #f)
(define tray #f)
(define shutting-down? #f)
(define (show-status! message)
(queue-callback
(lambda ()
(when status-message
(send status-message set-label message)))
#f))
(define (show-denial! message)
(queue-callback
(lambda ()
(message-box (tr 'denied-title)
message
frame
'(ok stop)))
#f))
(set! runtime
(make-player-agent-runtime
(player-agent-config-server-url config)
(player-agent-config-name config)
(player-agent-config-app-id config)
#:status-callback show-status!
#:denied-callback show-denial!))
(define (refresh-playback-status!)
(when (and playback-message playback-details playback-filename)
(define snapshot ((player-agent-runtime-snapshot runtime)))
(define track ((player-agent-runtime-current-track runtime)))
(define state (hash-ref snapshot 'state "stopped"))
(define title (and track (hash-ref track 'title #f)))
(define artist (and track (hash-ref track 'artist #f)))
(define filename (and track (hash-ref track 'filename #f)))
(define track-number (and track (hash-ref track 'trackNumber #f)))
(define track-label
(cond
((and artist (not (string=? artist "")) title)
(format "~a — ~a" artist title))
(title title)
(else (tr 'no-track-selected))))
(define prefix
(cond
((string=? state "playing") (tr 'playing))
((string=? state "paused") (tr 'paused))
((string=? state "starting") (tr 'loading))
((string=? state "stopped") (tr 'stopped))
(else state)))
(define position (hash-ref snapshot 'position 0))
(define duration (hash-ref snapshot 'duration 'null))
(define format-name (hash-ref snapshot 'format ""))
(define rate (hash-ref snapshot 'rate 'null))
(define bits (hash-ref snapshot 'bits 'null))
(define channels (hash-ref snapshot 'channels 'null))
(define details
(filter
(lambda (value) (not (string=? value "")))
(list
(format "~a / ~a"
(format-time position)
(if (number? duration) (format-time duration) "--:--:--"))
(if (number? bits) (format "~a bit" bits) "")
(if (number? rate)
(format "~a kHz" (~r (/ rate 1000.0) #:precision '(= 1)))
"")
(if (number? channels)
(format "~a ~a" channels
(tr (if (= channels 1) 'channel 'channels)))
"")
(if (and (string? format-name) (not (string=? format-name "")))
format-name
""))))
(send playback-message
set-label
(if track
(format "~a~a: ~a"
prefix
(if (number? track-number)
(format " #~a" track-number)
"")
track-label)
(tr 'no-track)))
(send playback-details set-label (string-join details " · "))
(send playback-filename
set-label
(if (and (string? filename) (not (string=? filename "")))
filename
""))))
(define (reconnect!)
(define next-server (string-trim (send server-field get-value)))
(define entered-name (string-trim (send name-field get-value)))
(define next-name
(if (string=? entered-name "")
(format "~a playback" (gethostname))
entered-name))
(set! config
(struct-copy player-agent-config config
(server-url next-server)
(name next-name)))
(save-player-agent-config! config)
(send name-field set-value next-name)
((player-agent-runtime-reconnect! runtime) next-server next-name)
(send connect-button set-label (tr 'reconnect)))
(define (shutdown!)
(unless shutting-down?
(set! shutting-down? #t)
(when playback-timer (send playback-timer stop))
(when tray-timer (send tray-timer stop))
((player-agent-runtime-shutdown! runtime))
(when tray
((tray-controller-destroy! tray))
(set! tray #f))))
(define (quit!)
(queue-callback
(lambda ()
(shutdown!)
(when frame (send frame show #f)))
#f))
(define agent-frame%
(class frame%
(super-new)
(define/augment (on-close)
(if tray
(send this show #f)
(begin
(shutdown!)
(inner (void) on-close))))))
(set! frame
(new agent-frame%
(label (tr 'app-title))
(width 560)
(height 310)))
(define panel
(new vertical-panel%
(parent frame)
(alignment '(left top))))
(set! server-field
(input-field (tr 'server)
(player-agent-config-server-url config)
panel))
(set! name-field
(input-field (tr 'name) (player-agent-config-name config) panel))
(define id-field
(input-field (tr 'application-id)
(player-agent-config-app-id config)
panel))
;; Lock the editor, not the native widget. Disabled Windows controls render
;; their label and text poorly on some display configurations.
(send (send id-field get-editor) lock #t)
(define playback-panel
(new group-box-panel%
(parent panel)
(label (tr 'playback))
(alignment '(left top))
(stretchable-height #f)))
(set! playback-message
(new message%
(parent playback-panel)
(label (tr 'no-track))
(auto-resize #t)))
(set! playback-details
(new message%
(parent playback-panel)
(label "00:00:00 / --:--:--")
(auto-resize #t)))
(set! playback-filename
(new message%
(parent playback-panel)
(label "")
(auto-resize #t)))
(define controls
(new horizontal-panel%
(parent panel)
(alignment '(left center))))
(set! connect-button
(new button%
(parent controls)
(label (tr 'save-connect))
(callback (lambda (_button _event) (reconnect!)))))
(set! status-message
(new message%
(parent controls)
(label (tr 'connecting))
(auto-resize #t)))
(set! playback-timer
(new timer%
(notify-callback refresh-playback-status!)
(interval 500)))
(refresh-playback-status!)
;; If SDL3 and its native runtime are present, closing the frame hides it in
;; the tray. Otherwise the original close-and-exit behaviour remains.
(set! tray
(try-make-tray-controller
(lambda ()
(queue-callback (lambda () (send frame show #t)) #f))
quit!))
(when tray
(set! tray-timer
(new timer%
(notify-callback (tray-controller-update! tray))
(interval 100))))
(send frame show #t)
((player-agent-runtime-start! runtime))
(send connect-button set-label (tr 'reconnect))
frame)
-36
View File
@@ -1,36 +0,0 @@
#lang racket/base
(require "translate.rkt")
;; SDL3 is deliberately loaded dynamically. The GUI agent keeps working
;; without the optional Racket package and native SDL3 runtime.
(provide (struct-out tray-controller)
try-make-tray-controller)
(struct tray-controller (update! destroy!) #:transparent)
(define (try-make-tray-controller show-window! quit!)
(with-handlers ((exn:fail? (lambda (_) #f)))
(define sdl-init! (dynamic-require 'sdl3 'sdl-init!))
(define sdl-quit! (dynamic-require 'sdl3 'sdl-quit!))
(define make-tray (dynamic-require 'sdl3 'make-tray))
(define make-tray-menu (dynamic-require 'sdl3 'make-tray-menu))
(define insert-tray-entry! (dynamic-require 'sdl3 'insert-tray-entry!))
(define set-tray-entry-callback!
(dynamic-require 'sdl3 'set-tray-entry-callback!))
(define update-trays! (dynamic-require 'sdl3 'update-trays!))
(define tray-destroy! (dynamic-require 'sdl3 'tray-destroy!))
(sdl-init! '(video events))
(define tray (make-tray #f (tr 'app-title)))
(define menu (make-tray-menu tray))
(define show-entry (insert-tray-entry! menu (tr 'tray-open)))
(insert-tray-entry! menu #f)
(define quit-entry (insert-tray-entry! menu (tr 'quit)))
(set-tray-entry-callback! show-entry (lambda (_) (show-window!)))
(set-tray-entry-callback! quit-entry (lambda (_) (quit!)))
(tray-controller
update-trays!
(lambda ()
(tray-destroy! tray)
(sdl-quit!)))))
+333 -64
View File
@@ -15,7 +15,8 @@
"library.rkt" "library.rkt"
"playlists.rkt") "playlists.rkt")
(provide make-player (provide player?
make-player
player-state->jsexpr player-state->jsexpr
player-command! player-command!
player-discover! player-discover!
@@ -49,11 +50,13 @@
#:transparent) #:transparent)
(struct playlist-tab (struct playlist-tab
(id [name #:mutable] [tracks #:mutable]) (id [name #:mutable] [tracks #:mutable] [snapshot #:auto #:mutable])
#:auto-value #f
#:transparent) #:transparent)
(struct playlist-context (struct playlist-context
([tabs #:mutable] [current-index #:mutable]) ([tabs #:mutable] [current-index #:mutable] [saved #:auto #:mutable])
#:auto-value '()
#:transparent) #:transparent)
(struct playback-session (struct playback-session
@@ -73,9 +76,19 @@
[volume #:mutable] [volume #:mutable]
[repeat #:mutable] [repeat #:mutable]
[error #:mutable] [error #:mutable]
local-music-indexes) local-music-indexes)
#:transparent) #: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 (struct player
(libraries (libraries
allowed-agent-ids allowed-agent-ids
@@ -249,36 +262,45 @@
(list-ref (player-tabs value) (list-ref (player-tabs value)
(player-current-tab-index value))) (player-current-tab-index value)))
;;; Invalidate the browser snapshot only when the immutable track list changes.
(define (save-current-tab! value) (define (save-current-tab! value)
(set-playlist-tab-tracks! (let ((tab (current-tab value))
(current-tab value) (tracks (player-tracks value)))
(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) (define (normal-playlist-username username)
(let ((value (and (string? username) (let ((value (and (string? username)
(string-downcase (string-trim username))))) (string-downcase (string-trim username)))))
(if (and value (not (string=? value ""))) value "anonymous"))) (if (and value (not (string=? value ""))) value "anonymous")))
(define (new-playlist-context value username) ;;; Restore open tabs and the library using the same object for a shared UUID.
(define stored ;;; Old stores have no saved index, so their tabs remain open and unsaved.
(load-user-playlists (player-playlist-store value) (define (restore-playlist-context store username libraries)
username (let* ((restore (λ (tab) (playlist-tab (persisted-tab-id tab)
(player-libraries value))) (persisted-tab-name tab)
(playlist-context (persisted-tab-tracks tab))))
(if (pair? stored) (opened (map restore (load-user-playlists store username libraries)))
(for/list ((tab (in-list stored))) (tabs (if (pair? opened) opened
(playlist-tab (persisted-tab-id tab) (list (playlist-tab (uuid-string) "Default" '()))))
(persisted-tab-name tab) (context (playlist-context tabs 0)))
(persisted-tab-tracks tab))) (set-playlist-context-saved!
(list (playlist-tab (uuid-string) "Default" '()))) context
0)) (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 (playlist-context-for! value username)
(define normalized (normal-playlist-username username)) (define normalized (normal-playlist-username username))
(hash-ref! (hash-ref!
(player-playlist-contexts value) (player-playlist-contexts value)
normalized normalized
(lambda () (new-playlist-context value normalized)))) (λ () (restore-playlist-context (player-playlist-store value)
normalized (player-libraries value)))))
(define (context-tracks context) (define (context-tracks context)
(playlist-tab-tracks (playlist-tab-tracks
@@ -324,7 +346,7 @@
(define context (playlist-context-for! value normalized)) (define context (playlist-context-for! value normalized))
(with-state-lock (with-state-lock
value value
(lambda () (λ ()
(set-player-tabs! value (playlist-context-tabs context)) (set-player-tabs! value (playlist-context-tabs context))
(set-player-current-tab-index! (set-player-current-tab-index!
value value
@@ -350,7 +372,12 @@
(for/list ((tab (in-list (player-tabs value)))) (for/list ((tab (in-list (player-tabs value))))
(persisted-tab (playlist-tab-id tab) (persisted-tab (playlist-tab-id tab)
(playlist-tab-name 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) (define (normalize-state state)
(cond (cond
@@ -373,6 +400,13 @@
(λ () (λ ()
(set-playback-session-error! session message)))) (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) (define (clear-session-error! value session)
(set-session-error! value session #f)) (set-session-error! value session #f))
@@ -909,25 +943,28 @@
trimmed) trimmed)
(persist-playlists! value))))) (persist-playlists! value)))))
;;; Close a tab, retaining saved playlists in the user's library.
(define (delete-tab! value session index) (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) (unless (and (exact-nonnegative-integer? index)
(< index (length (player-tabs value)))) (< index (length (player-tabs value))))
(raise-arguments-error (raise-arguments-error
'player-command! 'player-command!
"playlist tab does not exist" "playlist tab does not exist"
"index" index)) "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) (stop-playback! value session)
(with-state-lock (with-state-lock
value value
(λ () (λ ()
(save-current-tab! value) (save-current-tab! value)
(let* ((tabs (let* ((remaining
(append (take (player-tabs value) index) (append (take (player-tabs value) index)
(drop (player-tabs value) (+ index 1)))) (drop (player-tabs value) (+ index 1))))
(tabs (if (pair? remaining) remaining
(list (playlist-tab (uuid-string) "Default" '()))))
(new-index (new-index
(min (player-current-tab-index value) (min (player-current-tab-index value)
(- (length tabs) 1)))) (- (length tabs) 1))))
@@ -940,6 +977,44 @@
(set-playback-session-current-index! session #f) (set-playback-session-current-index! session #f)
(persist-playlists! value))))) (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) (define (track->jsexpr item index)
(hasheq 'index index (hasheq 'index index
'title (track-title item) 'title (track-title item)
@@ -966,11 +1041,29 @@
'name (browser-entry-name entry) 'name (browser-entry-name entry)
'kind (symbol->string (browser-entry-kind entry)))) 'kind (symbol->string (browser-entry-kind entry))))
(define (tab->jsexpr tab index) ;;; Cache serialized tracks and their summary until save-current-tab! invalidates
(hasheq 'index index ;;; them. A fresh opaque version also prevents cache reuse across server restarts.
'id (playlist-tab-id tab) (define (tab-snapshot tab)
'name (playlist-tab-name tab) (or (playlist-tab-snapshot tab)
'count (length (playlist-tab-tracks 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) (define (normal-device-id device)
(let ((id (upnp-device-udn device))) (let ((id (upnp-device-udn device)))
@@ -1100,7 +1193,12 @@
(rename-tab! value index (rename-tab! value index
(or (json-string data 'name #f) ""))) (or (json-string data 'name #f) "")))
((string=? command "tab-delete") ((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) (define (perform-command! value session command data)
(cond (cond
@@ -1110,7 +1208,7 @@
((member command '("track-remove" "track-move" ((member command '("track-remove" "track-move"
"playlist-clear" "tab-add" "playlist-clear" "tab-add"
"tab-select" "tab-rename" "tab-select" "tab-rename"
"tab-delete")) "tab-delete" "playlist-save" "playlist-open" "playlist-play"))
(perform-playlist-command! value session command data)) (perform-playlist-command! value session command data))
((string=? command "play") ((string=? command "play")
(play-index! (play-index!
@@ -1257,23 +1355,15 @@
app-id)) app-id))
(string-downcase app-id))) (string-downcase app-id)))
(define store (open-playlist-store playlist-keystore)) (define store (open-playlist-store playlist-keystore))
(define stored-tabs
(load-user-playlists store "anonymous" libraries))
(let* ((library (and (pair? libraries) (car libraries))) (let* ((library (and (pair? libraries) (car libraries)))
(browser-entries (browser-entries
(if library (if library
(browse-library library '()) (browse-library library '())
'())) '()))
(tabs (initial-context (restore-playlist-context store "anonymous" libraries))
(if (pair? stored-tabs) (tabs (playlist-context-tabs initial-context))
(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" '()))))
(selected-index 0) (selected-index 0)
(contexts (make-hash)) (contexts (make-hash)))
(initial-context (playlist-context tabs selected-index)))
(hash-set! contexts "anonymous" initial-context) (hash-set! contexts "anonymous" initial-context)
(define value (define value
(player libraries (player libraries
@@ -1303,12 +1393,17 @@
value)) 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. ; pre : Value was created with make-player.
; post : Cached DLNA playback information has been incorporated. ; 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)) (define normalized (normal-playlist-username username))
(call-with-semaphore (call-with-semaphore
(player-command-lock value) (player-command-lock value)
@@ -1319,7 +1414,7 @@
(define context (playlist-context-for! value normalized)) (define context (playlist-context-for! value normalized))
(define tabs (playlist-context-tabs context)) (define tabs (playlist-context-tabs context))
(define tab-index (playlist-context-current-index 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 (with-state-lock
value value
(λ () (λ ()
@@ -1345,12 +1440,17 @@
'tabs 'tabs
(for/list ((tab (in-list tabs)) (for/list ((tab (in-list tabs))
(index (in-naturals))) (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 'currentTab tab-index
'playlistVersion (hash-ref snapshot 'version)
'tracks 'tracks
(for/list ((item (in-list tracks)) (if (equal? playlist-version (hash-ref snapshot 'version))
(index (in-naturals))) 'null
(track->jsexpr item index)) (hash-ref snapshot 'tracks))
'renderers (map renderer->jsexpr 'renderers (map renderer->jsexpr
(player-renderers value)) (player-renderers value))
'rendererId (or (playback-session-selected-id session) 'null) 'rendererId (or (playback-session-selected-id session) 'null)
@@ -1372,22 +1472,24 @@
'volume (playback-session-volume session) 'volume (playback-session-volume session)
'repeat (symbol->string (playback-session-repeat session)) 'repeat (symbol->string (playback-session-repeat session))
'discovering (player-discovering? value) 'discovering (player-discovering? value)
'error (or (playback-session-error session) 'error (error->jsexpr
(player-error value) (or (playback-session-error session)
'null)))))))) (player-error value))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Execute one browser player command. ; goal : Execute one browser player command.
; pre : Command is a string and data is a JSON object hash. ; pre : Command is a string and data is a JSON object hash.
; post : The command has completed or a concrete exception is raised. ; 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 (define playlist-context-commands
'("item-play" "item-add" "track-remove" "track-move" '("item-play" "item-add" "track-remove" "track-move"
"playlist-clear" "tab-add" "tab-select" "tab-rename" "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)) (define normalized (normal-playlist-username username))
(call-with-semaphore (call-with-semaphore
(player-command-lock value) (player-command-lock value)
@@ -1405,7 +1507,8 @@
(when (member command playlist-context-commands) (when (member command playlist-context-commands)
(activate-playlist-user! value normalized session)) (activate-playlist-user! value normalized session))
(perform-command! value session command data)))) (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. ; goal : Discover UPnP renderers and logical Sonos groups asynchronously.
@@ -1649,7 +1752,7 @@
(define item (define item
(call-with-semaphore (call-with-semaphore
(player-command-lock value) (player-command-lock value)
(lambda () (λ ()
(define context (define context
(playlist-context-for! (playlist-context-for!
value value
@@ -1659,7 +1762,7 @@
(player-tracks value) (player-tracks value)
(append-map playlist-tab-tracks (append-map playlist-tab-tracks
(playlist-context-tabs context)))) (playlist-context-tabs context))))
(findf (lambda (candidate) (findf (λ (candidate)
(string=? (track-cache-key candidate) artwork-id)) (string=? (track-cache-key candidate) artwork-id))
candidates)))) candidates))))
(and item (track-artwork item))) (and item (track-artwork item)))
@@ -1718,10 +1821,176 @@
(λ () (λ ()
(set-player-closed?! value #t))))))) (set-player-closed?! value #t)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module player.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test (module+ test
(require rackunit (require json
rackunit
racket/file) 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 (define root
(make-temporary-file "rkt-web-player-~a" 'directory)) (make-temporary-file "rkt-web-player-~a" 'directory))
+271 -163
View File
@@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require keystore (require keystore
racket/contract
racket/file racket/file
racket/list racket/list
racket/path racket/path
@@ -15,18 +16,32 @@
load-user-language load-user-language
save-user-language!) save-user-language!)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Represent one named playlist tab in durable player state.
; pre : Id is a UUID string, name is non-empty, and tracks contains tracks.
; post : Constructing or inspecting a value changes no external state.
; result : persisted-tab? recognizes stored and restored playlist tabs.
; internals: track->datum serializes the tracks and datum->tab reconstructs
; this value after validating its id, name and track collection.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(struct persisted-tab (id name tracks) #:transparent) (struct persisted-tab (id name tracks) #:transparent)
(struct playlist-store (keystore lock) #:transparent)
(define (user-playlists-key username) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(format "playlists-for-~a" username)) ;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Keep open tabs and saved library playlists in separate ordered UUID indexes.
(define (user-playlists-key username [saved? #f])
(format "~aplaylists-for-~a" (if saved? "saved-" "") username))
;;; Produces the keystore key containing one user's language preference.
(define (user-language-key username) (define (user-language-key username)
(format "language-for-~a" username)) (format "language-for-~a" username))
(define supported-language-names (define supported-language-names
'("en" "nl" "de" "fr" "es" "it" "sv" "no" "fi" "is")) '("en" "nl" "de" "fr" "es" "it" "sv" "no" "fi" "is"))
;;; Serializes a track without exposing the track struct to the keystore.
(define (track->datum item) (define (track->datum item)
(hasheq 'file (path->string (track-file item)) (hasheq 'file (path->string (track-file item))
'title (track-title item) 'title (track-title item)
@@ -35,111 +50,188 @@
'duration (or (track-duration item) #f) 'duration (or (track-duration item) #f)
'mime-type (or (track-mime-type item) #f))) 'mime-type (or (track-mime-type item) #f)))
;;; Checks whether a stored optional value is #f or a string.
(define (optional-string? value) (define (optional-string? value)
(or (not value) (string? value))) (or (eq? value #f) (string? value)))
;;; Validates and restores one stored track.
;;; Files outside the configured libraries are deliberately rejected.
(define (datum->track value libraries) (define (datum->track value libraries)
(and (hash? value) (if (not (hash? value))
(let ((file (hash-ref value 'file #f)) #f
(let* ((file (hash-ref value 'file #f))
(title (hash-ref value 'title #f)) (title (hash-ref value 'title #f))
(artist (hash-ref value 'artist #f)) (artist (hash-ref value 'artist #f))
(album (hash-ref value 'album #f)) (album (hash-ref value 'album #f))
(duration (hash-ref value 'duration #f)) (duration (hash-ref value 'duration #f))
(mime-type (hash-ref value 'mime-type #f))) (mime-type (hash-ref value 'mime-type #f))
(and (path-string? file) (valid-duration?
(string? title) (or (eq? duration #f)
(string? artist) (and (number? duration)
(string? album) (not (negative? duration)))))
(or (not duration) (valid-metadata?
(and (number? duration) (not (negative? duration)))) (and (path-string? file)
(optional-string? mime-type) (string? title)
(library-contains-audio-file? libraries file) (string? artist)
(track (path->complete-path file) (string? album)
title artist album duration mime-type))))) valid-duration?
(optional-string? mime-type))))
(if (and valid-metadata?
(library-contains-audio-file? libraries file))
(track (path->complete-path file)
title artist album duration mime-type)
#f))))
;;; Validates and restores one tab while discarding invalid track entries.
(define (datum->tab id value libraries) (define (datum->tab id value libraries)
(and (uuid-string? id) (if (not (and (uuid-string? id) (hash? value)))
(hash? value) #f
(let ((name (hash-ref value 'name #f)) (let ((name (hash-ref value 'name #f))
(tracks (hash-ref value 'tracks #f))) (tracks (hash-ref value 'tracks #f)))
(and (string? name) (if (and (string? name)
(not (string=? name "")) (not (string=? name ""))
(list? tracks) (list? tracks))
(persisted-tab (persisted-tab
id id
name name
(filter-map (filter-map
(lambda (item) (datum->track item libraries)) (λ (item) (datum->track item libraries))
tracks)))))) tracks))
#f))))
(define (open-playlist-store file) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(and file ;; Provided functions
(let ((target (path->complete-path file))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(make-parent-directory* target)
(playlist-store (ks-open target) (make-semaphore 1)))))
(define (close-playlist-store! store) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Open the durable store used for playlists and user preferences.
; pre : File is #f or a writable keystore path.
; post : The parent directory and keystore exist when file is provided.
; result : An open keystore handle, or #f when persistence is disabled.
; internals: path->complete-path fixes the storage location, ks-open creates or
; opens the keystore, and later operations use the lock belonging to
; the returned handle.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (open-playlist-store file)
(-> (or/c path-string? #f) (or/c keystore? #f))
(if (eq? file #f)
#f
(let ((target (path->complete-path file)))
(make-parent-directory* target)
(ks-open target))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Close an open playlist store.
; pre : Store is #f or was returned by open-playlist-store.
; post : Its keystore handle is closed; #f remains a harmless no-op.
; result : Void.
; internals: ks-with-lock uses the lock belonging to the keystore handle and
; prevents ks-close from overlapping a load or save operation.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (close-playlist-store! store)
(-> (or/c keystore? #f) void?)
(when store (when store
(call-with-semaphore (ks-with-lock store (λ () (ks-close store))))
(playlist-store-lock store)
(lambda () (ks-close (playlist-store-keystore store)))))
(void)) (void))
(define (load-user-playlists store username libraries) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (not store) ; goal : Restore one user's open tabs, or saved library playlists with saved?.
; pre : Store is #f or open, username is normalized, and libraries are valid.
; post : Store contents remain unchanged and unsafe track paths are omitted.
; result : Valid persisted-tab values in their saved order.
; internals: ks-with-lock serializes the index and tab reads on the keystore
; handle. user-playlists-key locates the UUID index; datum->tab then
; validates each referenced tab and delegates track safety checks to
; datum->track.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (load-user-playlists store username libraries #:saved? [saved? #f])
(->* ((or/c keystore? #f) string? (listof music-library?))
(#:saved? boolean?)
(listof persisted-tab?))
(if (eq? store #f)
'() '()
(call-with-semaphore (ks-with-lock
(playlist-store-lock store) store
(lambda () (λ ()
(define ks (playlist-store-keystore store)) (let ((ids (ks-get store (user-playlists-key username saved?) '())))
(define ids (ks-get ks (user-playlists-key username) '())) (if (list? ids)
(if (list? ids) (filter-map
(filter-map (λ (id)
(lambda (id) (datum->tab id (ks-get store id #f) libraries))
(datum->tab id (ks-get ks id #f) libraries)) (remove-duplicates (filter uuid-string? ids) string=?))
(remove-duplicates (filter uuid-string? ids) string=?)) '()))))))
'())))))
(define (save-user-playlists! store username tabs) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Persist one user's open tabs and saved library playlists atomically.
; pre : Store is #f or open, username is normalized, and tabs are valid.
; post : Both UUID indexes match tabs/saved. Closing a saved tab retains its
; data; playlists absent from both indexes are removed.
; result : Void.
; internals: ks-with-lock prevents another operation from entering this update.
; ks-transaction removes stale ids from user-playlists-key, stores
; each distinct playlist using track->datum, and replaces both indexes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (save-user-playlists! store username tabs #:saved [saved '()])
(->* ((or/c keystore? #f) string? (listof persisted-tab?))
(#:saved (listof persisted-tab?))
void?)
(when store (when store
(call-with-semaphore (ks-with-lock
(playlist-store-lock store) store
(lambda () (λ ()
(define ks (playlist-store-keystore store)) (let* ((index-key (user-playlists-key username))
(define index-key (user-playlists-key username)) (saved-key (user-playlists-key username #t))
(define old-ids (ks-get ks index-key '())) (old-open (ks-get store index-key '()))
(define ids (map persisted-tab-id tabs)) (old-saved (ks-get store saved-key '()))
(ks-transaction (old-ids (append (if (list? old-open) old-open '())
ks (if (list? old-saved) old-saved '())))
(for ((id (in-list (if (list? old-ids) old-ids '()))) (ids (map persisted-tab-id tabs))
#:when (and (string? id) (not (member id ids string=?)))) (saved-ids (map persisted-tab-id saved))
(ks-drop! ks id)) (all-tabs (remove-duplicates (append tabs saved)
(for ((tab (in-list tabs))) string=? #:key persisted-tab-id))
(ks-set! (stale-ids
ks (filter
(persisted-tab-id tab) (λ (id)
(hasheq 'name (persisted-tab-name tab) (and (string? id)
'tracks (map track->datum (not (member id ids string=?))
(persisted-tab-tracks tab))))) (not (member id saved-ids string=?))))
(ks-set! ks index-key ids)) (remove-duplicates old-ids))))
(void))))) (ks-transaction
store
(for-each (λ (id) (ks-drop! store id)) stale-ids)
(for-each
(λ (tab)
(ks-set!
store
(persisted-tab-id tab)
(hasheq 'name (persisted-tab-name tab)
'tracks (map track->datum
(persisted-tab-tracks tab)))))
all-tabs)
(ks-set! store index-key ids)
(ks-set! store saved-key saved-ids))
(void)))))
(void))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Load one user's persisted interface language. ; goal : Load one user's persisted interface language.
; pre : Store is #f or an open playlist store; username is normalized. ; pre : Store is #f or an open playlist store; username is normalized.
; post : Store contents remain unchanged. ; post : Store contents remain unchanged.
; result : A supported ISO language name, or #f when none was saved. ; result : A supported ISO language name, or #f when none was saved.
; internals: user-language-key selects the keystore entry while ks-with-lock
; holds the handle's lock. Only supported language names return.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (load-user-language store username) (define/contract (load-user-language store username)
(and store (-> (or/c keystore? #f) string? (or/c string? #f))
(call-with-semaphore (if (eq? store #f)
(playlist-store-lock store) #f
(λ () (ks-with-lock
(define value store
(ks-get (playlist-store-keystore store) (λ ()
(user-language-key username) (let ((value (ks-get store (user-language-key username) #f)))
#f)) (if (member value supported-language-names)
(and (member value supported-language-names) value))))) value
#f))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Persist one user's interface language. ; goal : Persist one user's interface language.
@@ -147,22 +239,27 @@
; en, nl, de, fr, es, it, sv, no, fi, or is. ; en, nl, de, fr, es, it, sv, no, fi, or is.
; post : The user's language key contains language when a store exists. ; post : The user's language key contains language when a store exists.
; result : Void. ; result : Void.
; internals: Validation precedes persistence. user-language-key identifies the
; entry and ks-with-lock serializes the ks-set! call on the handle.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (save-user-language! store username language) (define/contract (save-user-language! store username language)
(-> (or/c keystore? #f) string? string? void?)
(unless (member language supported-language-names) (unless (member language supported-language-names)
(raise-argument-error (raise-argument-error
'save-user-language! 'save-user-language!
"one of en, nl, de, fr, es, it, sv, no, fi, or is" "one of en, nl, de, fr, es, it, sv, no, fi, or is"
language)) language))
(when store (when store
(call-with-semaphore (ks-with-lock
(playlist-store-lock store) store
(λ () (λ ()
(ks-set! (playlist-store-keystore store) (ks-set! store (user-language-key username) language))))
(user-language-key username)
language))))
(void)) (void))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module playlists.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test (module+ test
(require rackunit (require rackunit
uuid/random) uuid/random)
@@ -173,84 +270,95 @@
(define music-two (build-path root "music-two")) (define music-two (build-path root "music-two"))
(define outside (build-path root "outside.flac")) (define outside (build-path root "outside.flac"))
(define store-file (build-path root "data" "playlists.keystore")) (define store-file (build-path root "data" "playlists.keystore"))
(check-false (open-playlist-store #f))
(check-equal? (load-user-playlists #f "hans" '()) '())
(check-false (load-user-language #f "hans"))
(dynamic-wind (dynamic-wind
(lambda () (λ ()
(make-directory music) (make-directory music)
(make-directory music-two) (make-directory music-two)
(call-with-output-file (build-path music "one.flac") void) (call-with-output-file (build-path music "one.flac") void)
(call-with-output-file (build-path music-two "two.flac") void) (call-with-output-file (build-path music-two "two.flac") void)
(call-with-output-file outside void)) (call-with-output-file outside void))
(lambda () (λ ()
(define libraries (make-music-libraries (list music music-two))) (let* ((libraries (make-music-libraries (list music music-two)))
(define store (open-playlist-store store-file)) (store (open-playlist-store store-file))
(define first-id (uuid-string)) (first-id (uuid-string))
(define second-id (uuid-string)) (second-id (uuid-string))
(define item (item
(track (build-path music "one.flac") (track (build-path music "one.flac")
"One" "Artist" "Album" 60 "audio/flac")) "One" "Artist" "Album" 60 "audio/flac"))
(define item-two (item-two
(track (build-path music-two "two.flac") (track (build-path music-two "two.flac")
"Two" "Artist" "Album" 70 "audio/flac")) "Two" "Artist" "Album" 70 "audio/flac")))
(save-user-playlists! (dynamic-wind
store void
"hans" (λ ()
(list (persisted-tab first-id "First" (list item item-two)) (save-user-playlists!
(persisted-tab second-id "Second" '()))) store
(save-user-playlists! "hans"
store (list (persisted-tab first-id "First" (list item item-two))
"local" (persisted-tab second-id "Second" '())))
(list (persisted-tab (uuid-string) "Local" '()))) (save-user-playlists!
store
"local"
(list (persisted-tab (uuid-string) "Local" '())))
(let ((loaded (load-user-playlists store "hans" libraries)))
(check-equal? (ks-get store "playlists-for-hans")
(list first-id second-id))
(check-equal? (hash-ref (ks-get store first-id) 'name) "First")
(check-equal? (map persisted-tab-id loaded)
(list first-id second-id))
(check-equal? (persisted-tab-name (car loaded)) "First")
(check-equal?
(map track-title (persisted-tab-tracks (car loaded)))
'("One" "Two"))
(check-equal?
(map persisted-tab-name
(load-user-playlists store "local" libraries))
'("Local"))
(check-false (load-user-language store "hans"))
(save-user-language! store "hans" "fr")
(check-equal? (load-user-language store "hans") "fr")
(save-user-language! store "hans" "fi")
(check-equal? (load-user-language store "hans") "fi")
(check-exn exn:fail:contract?
(λ () (save-user-language! store "hans" "da")))
(define loaded (load-user-playlists store "hans" libraries)) ;; Rewriting the user's GUID index durably removes the omitted
(define ks (playlist-store-keystore store)) ;; playlist instead of leaving it orphaned.
(check-equal? (ks-get ks "playlists-for-hans") (save-user-playlists!
(list first-id second-id)) store "hans"
(check-equal? (hash-ref (ks-get ks first-id) 'name) "First") (list (persisted-tab first-id "First" (list item item-two))))
(check-equal? (map persisted-tab-id loaded) (list first-id second-id)) (check-equal?
(check-equal? (persisted-tab-name (car loaded)) "First") (map persisted-tab-id
(check-equal? (map track-title (persisted-tab-tracks (car loaded))) (load-user-playlists store "hans" libraries))
'("One" "Two")) (list first-id))
(check-equal? (check-false (ks-exists? store second-id))
(map persisted-tab-name (load-user-playlists store "local" libraries)) (check-equal?
'("Local")) (map persisted-tab-name
(check-false (load-user-language store "hans")) (load-user-playlists store "local" libraries))
(save-user-language! store "hans" "fr") '("Local"))
(check-equal? (load-user-language store "hans") "fr")
(save-user-language! store "hans" "fi")
(check-equal? (load-user-language store "hans") "fi")
(check-exn exn:fail:contract?
(λ () (save-user-language! store "hans" "da")))
;; Rewriting the user's GUID index durably removes the omitted playlist. ;; A playlist may not restore tracks outside configured libraries.
(save-user-playlists! (let ((unsafe-id (uuid-string)))
store "hans" (ks-set!
(list (persisted-tab first-id "First" (list item item-two)))) store
(check-equal? unsafe-id
(map persisted-tab-id (load-user-playlists store "hans" libraries)) (hasheq
(list first-id)) 'name "Unsafe"
(check-false (ks-exists? ks second-id)) 'tracks
;; An omitted GUID is deleted rather than becoming orphaned. (list (hasheq 'file (path->string outside)
(check-equal? 'title "Outside" 'artist "" 'album ""
(map persisted-tab-name (load-user-playlists store "local" libraries)) 'duration #f 'mime-type "audio/flac"))))
'("Local")) (ks-set! store
(user-playlists-key "unsafe")
;; A playlist entry may not restore tracks outside configured libraries. (list unsafe-id))
(define unsafe-id (uuid-string)) (check-equal?
(ks-set! (persisted-tab-tracks
(playlist-store-keystore store) (car (load-user-playlists store "unsafe" libraries)))
unsafe-id '()))))
(hasheq (λ () (close-playlist-store! store)))))
'name "Unsafe" (λ () (delete-directory/files root))))
'tracks
(list (hasheq 'file (path->string outside)
'title "Outside" 'artist "" 'album ""
'duration #f 'mime-type "audio/flac"))))
(ks-set! (playlist-store-keystore store)
(user-playlists-key "unsafe")
(list unsafe-id))
(check-equal?
(persisted-tab-tracks
(car (load-user-playlists store "unsafe" libraries)))
'())
(close-playlist-store! store))
(lambda () (delete-directory/files root))))
+271 -106
View File
@@ -21,43 +21,46 @@
(define-runtime-path public-directory "../public") (define-runtime-path public-directory "../public")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTTP handlers ;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define current-player #f) ;;; Creates a JSON response that browsers and agents may not cache.
(define current-auth #f)
(define (json-response value #:code [code 200] #:headers [headers '()]) (define (json-response value #:code [code 200] #:headers [headers '()])
(response/jsexpr (response/jsexpr
value value
#:code code #:code code
#:headers (cons (header #"Cache-Control" #"no-store") headers))) #:headers (cons (header #"Cache-Control" #"no-store") headers)))
;;; Converts an ordinary request exception to a bad-request response.
(define (error-response exception) (define (error-response exception)
(json-response (json-response
(hasheq 'error (exn-message exception)) (hasheq 'error (exn-message exception))
#:code 400)) #:code 400))
;;; Converts a denied playback agent exception to a forbidden response.
(define (agent-error-response exception) (define (agent-error-response exception)
(json-response (json-response
(hasheq 'error (exn-message exception) (hasheq 'error (exn-message exception)
'code "agent-not-authorized") 'code "agent-not-authorized")
#:code 403)) #:code 403))
;;; Reads a JSON request body or returns an empty object for an empty body.
(define (request-jsexpr request) (define (request-jsexpr request)
(let ((body (request-post-data/raw request))) (let ((body (request-post-data/raw request)))
(if (and body (positive? (bytes-length body))) (if (and body (positive? (bytes-length body)))
(bytes->jsexpr body) (bytes->jsexpr body)
(hasheq)))) (hasheq))))
(define (auth-status-handler request) ;;; Reports the authentication state belonging to the current request.
(let ((user (auth-request-user current-auth request))) (define (auth-status-handler auth request)
(let ((user (auth-request-user auth request)))
(json-response (json-response
(hasheq 'enabled (auth-enabled? current-auth) (hasheq 'enabled (auth-enabled? auth)
'authenticated (and user #t) 'authenticated (and user #t)
'username (or user 'null))))) 'username (or user 'null)))))
(define (auth-login-handler request) ;;; Authenticates a browser and returns its new session cookie.
(define (auth-login-handler auth request)
(with-handlers ((exn:fail? error-response)) (with-handlers ((exn:fail? error-response))
(let* ((data (request-jsexpr request)) (let* ((data (request-jsexpr request))
(username (hash-ref data 'username #f)) (username (hash-ref data 'username #f))
@@ -66,16 +69,16 @@
(raise-arguments-error (raise-arguments-error
'login 'login
"username and password must be strings")) "username and password must be strings"))
(let ((result (auth-login! current-auth request username password))) (let ((result (auth-login! auth request username password)))
(cond (cond
((eq? result 'rate-limited) ((eq? result 'rate-limited)
(json-response (json-response
(hasheq 'error "Te veel mislukte aanmeldpogingen; probeer het over enkele minuten opnieuw" (hasheq 'error "login-rate-limited"
'code "login-rate-limited") 'code "login-rate-limited")
#:code 429)) #:code 429))
((not result) ((not result)
(json-response (json-response
(hasheq 'error "Ongeldige gebruikersnaam of wachtwoord" (hasheq 'error "invalid-credentials"
'code "invalid-credentials") 'code "invalid-credentials")
#:code 401)) #:code 401))
(else (else
@@ -84,79 +87,97 @@
'username (string-downcase (string-trim username))) 'username (string-downcase (string-trim username)))
#:headers #:headers
(list (header #"Set-Cookie" (list (header #"Set-Cookie"
(auth-session-cookie current-auth result)))))))))) (auth-session-cookie auth result))))))))))
(define (auth-logout-handler request) ;;; Invalidates the browser session and expires its cookie.
(auth-logout! current-auth request) (define (auth-logout-handler auth request)
(auth-logout! auth request)
(json-response (json-response
(hasheq 'authenticated #f) (hasheq 'authenticated #f)
#:headers #:headers
(list (header #"Set-Cookie" (auth-expired-cookie))))) (list (header #"Set-Cookie" (auth-expired-cookie)))))
(define (request-username request) ;;; Resolves the authenticated username or the anonymous playlist owner.
(or (auth-request-user current-auth request) "anonymous")) (define (request-username auth request)
(or (auth-request-user auth request) "anonymous"))
(define (state-handler request) ;;; Read the opaque version of the playlist already held by this browser.
(define (request-playlist-version request)
(let ((entry (assq 'playlistVersion (url-query (request-uri request)))))
(and entry (cdr entry))))
;;; Returns user state, including tracks only when this browser needs them.
(define (state-handler player auth request)
(json-response (json-response
(player-state->jsexpr (player-state->jsexpr
current-player player
#:username (request-username request)))) #:username (request-username auth request)
#:playlist-version (request-playlist-version request))))
(define (discover-handler request) ;;; Starts renderer discovery and returns the updated player state.
(player-discover! current-player) (define (discover-handler player auth request)
(player-discover! player)
(json-response (json-response
(player-state->jsexpr (player-state->jsexpr
current-player player
#:username (request-username request)))) #:username (request-username auth request)
#:playlist-version (request-playlist-version request))))
(define (command-handler request command) ;;; Applies one player command for the requesting user.
(define (command-handler player auth request command)
(with-handlers (with-handlers
((exn:fail? error-response)) ((exn:fail? error-response))
(json-response (json-response
(player-command! (player-command!
current-player player
command command
(request-jsexpr request) (request-jsexpr request)
#:username (request-username request))))) #:username (request-username auth request)
#:playlist-version (request-playlist-version request)))))
(define (preferences-handler request) ;;; Returns the persisted interface preferences for the requesting user.
(define (preferences-handler player auth request)
(json-response (json-response
(hasheq (hasheq
'language 'language
(or (player-user-language (or (player-user-language
current-player player
#:username (request-username request)) #:username (request-username auth request))
'null)))) 'null))))
(define (preferences-update-handler request) ;;; Validates and persists the requesting user's interface language.
(define (preferences-update-handler player auth request)
(with-handlers ((exn:fail? error-response)) (with-handlers ((exn:fail? error-response))
(define language (hash-ref (request-jsexpr request) 'language #f)) (let ((language (hash-ref (request-jsexpr request) 'language #f)))
(player-user-language! (player-user-language!
current-player player
language language
#:username (request-username request)) #:username (request-username auth request))
(json-response (hasheq 'language language)))) (json-response (hasheq 'language language)))))
(define (agent-register-handler request) ;;; Registers or refreshes one allowed polling playback agent.
(define (agent-register-handler player request)
(with-handlers (with-handlers
((exn:fail:agent-denied? agent-error-response) ((exn:fail:agent-denied? agent-error-response)
(exn:fail? error-response)) (exn:fail? error-response))
(json-response (json-response
(player-agent-register! (player-agent-register!
current-player player
(request-jsexpr request))))) (request-jsexpr request)))))
(define (agent-poll-handler request) ;;; Processes one state report and command poll from a playback agent.
(define (agent-poll-handler player request)
(with-handlers (with-handlers
((exn:fail:agent-denied? agent-error-response) ((exn:fail:agent-denied? agent-error-response)
(exn:fail? error-response)) (exn:fail? error-response))
(json-response (json-response
(player-agent-poll! (player-agent-poll!
current-player player
(request-jsexpr request))))) (request-jsexpr request)))))
(define (agent-media-handler _request app-id token) ;;; Streams the media file identified by an agent's opaque token.
(let ((file (player-agent-media current-player app-id token))) (define (agent-media-handler player _request app-id token)
(let ((file (player-agent-media player app-id token)))
(if (and file (file-exists? file)) (if (and file (file-exists? file))
(response/output (response/output
(λ (output) (λ (output)
@@ -179,50 +200,34 @@
(hasheq 'error "media token is invalid or expired") (hasheq 'error "media token is invalid or expired")
#:code 404)))) #:code 404))))
(define (artwork-handler request artwork-id) ;;; Streams cached artwork belonging to a track visible to the user.
(define (artwork-handler player auth request artwork-id)
(let ((value (player-track-artwork (let ((value (player-track-artwork
current-player player
artwork-id artwork-id
#:username (request-username request)))) #:username (request-username auth request))))
(if value (if value
(response/output (let ((data (artwork-data value)))
(λ (output) (response/output
(write-bytes (artwork-data value) output)) (λ (output)
#:mime-type (write-bytes data output))
(string->bytes/utf-8 (artwork-mime-type value)) #:mime-type
#:headers (string->bytes/utf-8 (artwork-mime-type value))
(list #:headers
(header #"Content-Length" (list
(string->bytes/utf-8 (header #"Content-Length"
(number->string (string->bytes/utf-8
(bytes-length (artwork-data value))))) (number->string (bytes-length data))))
(header #"Cache-Control" #"private, max-age=3600"))) (header #"Cache-Control" #"private, max-age=3600"))))
(json-response (json-response
(hasheq 'error "track artwork is unavailable") (hasheq 'error "track artwork is unavailable")
#:code 404)))) #:code 404))))
(define-values (api-dispatch _url) ;;; Returns the path and query string used to classify an API request.
(dispatch-rules
[("api" "auth" "status") #:method "get" auth-status-handler]
[("api" "auth" "login") #:method "post" auth-login-handler]
[("api" "auth" "logout") #:method "post" auth-logout-handler]
[("api" "state") #:method "get" state-handler]
[("api" "discover") #:method "post" discover-handler]
[("api" "preferences") #:method "get" preferences-handler]
[("api" "preferences") #:method "post" preferences-update-handler]
[("api" "agent" "register") #:method "post" agent-register-handler]
[("api" "agent" "poll") #:method "post" agent-poll-handler]
[("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]))
(define (request-path request) (define (request-path request)
(url->string (request-uri request))) (url->string (request-uri request)))
;;; Checks whether the request declares a JSON entity body.
(define (json-request? request) (define (json-request? request)
(let ((content-type (let ((content-type
(headers-assq* #"Content-Type" (request-headers/raw request)))) (headers-assq* #"Content-Type" (request-headers/raw request))))
@@ -230,6 +235,7 @@
(regexp-match? #px#"(?i:^application/json(?:;|$))" (regexp-match? #px#"(?i:^application/json(?:;|$))"
(header-value content-type))))) (header-value content-type)))))
;;; Recognizes endpoints that use authentication rules separate from browsers.
(define (public-api-request? request) (define (public-api-request? request)
(regexp-match? #px"^/api/(?:auth|agent)(?:/|$)" (regexp-match? #px"^/api/(?:auth|agent)(?:/|$)"
(request-path request))) (request-path request)))
@@ -251,40 +257,95 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Dispatch an API request and renew an eligible browser cookie. ; goal : Dispatch an API request and renew an eligible browser cookie.
; pre : Current-player and current-auth are initialized and request targets ; pre : Auth is an auth-manager, api-dispatch handles the configured routes,
; an API route. ; and request targets an API route.
; post : The selected handler has run. A due browser-session renewal is ; post : The selected handler has run. A due browser-session renewal is
; recorded and returned as Set-Cookie; agent requests never renew it. ; recorded and returned as Set-Cookie; agent requests never renew it.
; result : The HTTP response produced by the API handler, optionally extended ; result : The HTTP response produced by the API handler, optionally extended
; with the renewed session cookie. ; with the renewed session cookie.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (dispatch-api request) (define (dispatch-api auth api-dispatch request)
(define value (api-dispatch request)) (let* ((value (api-dispatch request))
(define renewed-cookie (agent-request?
(and (not (regexp-match? #px"^/api/agent(?:/|$)" (regexp-match? #px"^/api/agent(?:/|$)" (request-path request)))
(request-path request))) (renewed-cookie
(auth-renewal-cookie current-auth request))) (if agent-request?
(if renewed-cookie #f
(response-add-header value (header #"Set-Cookie" renewed-cookie)) (auth-renewal-cookie auth request))))
value)) (if renewed-cookie
(response-add-header value (header #"Set-Cookie" renewed-cookie))
value)))
(define (dispatch request) ;;; Enforces JSON and authentication requirements before route dispatch.
(define (dispatch-request auth api-dispatch request)
(cond (cond
((and (bytes=? (request-method request) #"POST") ((and (bytes=? (request-method request) #"POST")
(not (json-request? request))) (not (json-request? request)))
(json-response (json-response
(hasheq 'error "Content-Type application/json is vereist" (hasheq 'error "json-required"
'code "json-required") 'code "json-required")
#:code 415)) #:code 415))
((or (public-api-request? request) ((or (public-api-request? request)
(auth-request-user current-auth request)) (auth-request-user auth request))
(dispatch-api request)) (dispatch-api auth api-dispatch request))
(else (else
(json-response (json-response
(hasheq 'error "Aanmelden is vereist" (hasheq 'error "authentication-required"
'code "authentication-required") 'code "authentication-required")
#:code 401)))) #:code 401))))
;;; Binds the player and authentication manager to every declared API route.
(define (make-api-dispatch player auth)
(let-values
(((api-dispatch _url)
(dispatch-rules
[("api" "auth" "status")
#:method "get"
(λ (request) (auth-status-handler auth request))]
[("api" "auth" "login")
#:method "post"
(λ (request) (auth-login-handler auth request))]
[("api" "auth" "logout")
#:method "post"
(λ (request) (auth-logout-handler auth request))]
[("api" "state")
#:method "get"
(λ (request) (state-handler player auth request))]
[("api" "discover")
#:method "post"
(λ (request) (discover-handler player auth request))]
[("api" "preferences")
#:method "get"
(λ (request) (preferences-handler player auth request))]
[("api" "preferences")
#:method "post"
(λ (request) (preferences-update-handler player auth request))]
[("api" "agent" "register")
#:method "post"
(λ (request) (agent-register-handler player request))]
[("api" "agent" "poll")
#:method "post"
(λ (request) (agent-poll-handler player request))]
[("api" "agent" "media" (string-arg) (string-arg))
#:method "get"
(λ (request app-id token)
(agent-media-handler player request app-id token))]
[("api" "artwork" (string-arg))
#:method "get"
(λ (request artwork-id)
(artwork-handler player auth request artwork-id))]
[("api" "command" (string-arg))
#:method "post"
(λ (request command)
(command-handler player auth request command))])))
api-dispatch))
;;; Creates the servlet dispatcher whose closure owns one player/auth pair.
(define (make-dispatch player auth)
(let ((api-dispatch (make-api-dispatch player auth)))
(λ (request)
(dispatch-request auth api-dispatch request))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions ;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -294,6 +355,9 @@
; pre : Value is a player, listen-ip is a string, and port is valid. ; pre : Value is a player, listen-ip is a string, and port is valid.
; post : Static files and API routes are served until the server stops. ; post : Static files and API routes are served until the server stops.
; result : The result returned by serve/servlet. ; result : The result returned by serve/servlet.
; internals: make-dispatch binds value and auth-manager into one request
; closure. make-api-dispatch connects that context to every route;
; serve/servlet then serves the closure and public-directory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (serve-player value (define/contract (serve-player value
#:auth-manager #:auth-manager
@@ -301,21 +365,122 @@
#:listen-ip [listen-ip "127.0.0.1"] #:listen-ip [listen-ip "127.0.0.1"]
#:port [port 8080] #:port [port 8080]
#:launch-browser? [launch-browser? #t]) #:launch-browser? [launch-browser? #t])
(->* (any/c) (->* (player?)
(#:auth-manager auth-manager? (#:auth-manager auth-manager?
#:listen-ip string? #:listen-ip string?
#:port exact-positive-integer? #:port exact-positive-integer?
#:launch-browser? boolean?) #:launch-browser? boolean?)
any) any)
(set! current-player value) (let ((dispatch (make-dispatch value auth-manager)))
(set! current-auth auth-manager) (serve/servlet
(serve/servlet dispatch
dispatch #:listen-ip listen-ip
#:listen-ip listen-ip #:port port
#:port port #:connection-close? #t
#:connection-close? #t #:launch-browser? launch-browser?
#:launch-browser? launch-browser? #:quit? #f
#:quit? #f #:banner? #t
#:banner? #t #:servlet-regexp #rx"^/api(?:/|$)"
#:servlet-regexp #rx"^/api(?:/|$)" #:extra-files-paths (list public-directory))))
#:extra-files-paths (list public-directory)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module server.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require racket/promise
rackunit)
;;; Creates an isolated request value for handler and dispatcher tests.
(define (test-request method path
#:headers [headers '()]
#:body [body #f])
(request method
(string->url path)
headers
(delay '())
body
"127.0.0.1"
8080
"127.0.0.1"))
;;; Reads the JSON entity produced by a response.
(define (response-jsexpr value)
(let ((output (open-output-bytes)))
((response-output value) output)
(bytes->jsexpr (get-output-bytes output))))
(check-equal?
(request-jsexpr (test-request #"POST" "/api/preferences"))
(hasheq))
(test-case "HTTP state and commands accept the browser's playlist version"
(let* ((value (make-player '() #:playlist-keystore #f #:local-output? #f))
(auth (make-auth-manager '()))
(dispatch (make-dispatch value auth)))
(dynamic-wind
void
(λ ()
(let* ((full (response-jsexpr (dispatch (test-request #"GET" "/api/state"))))
(version (hash-ref full 'playlistVersion))
(compact
(response-jsexpr
(dispatch (test-request #"GET" (string-append "/api/state?playlistVersion=" version))))))
(check-equal? (hash-ref full 'tracks) '())
(check-eq? (hash-ref compact 'tracks) 'null)
(check-equal? (hash-ref compact 'playlistVersion) version)
(let ((renamed
(response-jsexpr
(dispatch
(test-request #"POST"
(string-append "/api/command/tab-rename?playlistVersion=" version)
#:headers (list (header #"Content-Type" #"application/json"))
#:body #"{\"index\":0,\"name\":\"Music\"}")))))
(check-eq? (hash-ref renamed 'tracks) 'null)
(check-equal? (hash-ref (car (hash-ref renamed 'tabs)) 'name) "Music"))))
(λ () (player-close! value)))))
(check-equal?
(request-jsexpr
(test-request #"POST"
"/api/preferences"
#:body #"{\"language\":\"nl\"}"))
(hasheq 'language "nl"))
(check-true
(json-request?
(test-request
#"POST"
"/api/preferences"
#:headers (list (header #"Content-Type"
#"application/json; charset=utf-8")))))
(check-false (json-request? (test-request #"POST" "/api/preferences")))
(check-true (public-api-request? (test-request #"GET" "/api/auth/status")))
(check-true (public-api-request? (test-request #"POST" "/api/agent/poll")))
(check-false (public-api-request? (test-request #"GET" "/api/state")))
(let* ((auth (make-auth-manager (list (cons "hans" "$argon2id$unused"))))
(request (test-request #"GET" "/api/state"))
(response
(dispatch-request auth
(λ (_) (error 'test "unexpected dispatch"))
request)))
(check-equal? (response-code response) 401)
(check-equal? (hash-ref (response-jsexpr response) 'error)
"authentication-required"))
(let* ((auth (make-auth-manager '()))
(request (test-request #"POST" "/api/state"))
(response
(dispatch-request auth
(λ (_) (error 'test "unexpected dispatch"))
request)))
(check-equal? (response-code response) 415)
(check-equal? (hash-ref (response-jsexpr response) 'error)
"json-required"))
(let* ((auth (make-auth-manager '()))
(dispatch (make-dispatch 'unused-player auth))
(response (dispatch (test-request #"GET" "/api/auth/status")))
(data (response-jsexpr response)))
(check-equal? (response-code response) 200)
(check-false (hash-ref data 'enabled))
(check-true (hash-ref data 'authenticated))
(check-equal? (hash-ref data 'username) "anonymous")))
+322 -202
View File
@@ -2,7 +2,8 @@
(require crypto (require crypto
crypto/argon2 crypto/argon2
net/private/ip net/ip
racket/contract
racket/list racket/list
racket/random racket/random
racket/string racket/string
@@ -21,10 +22,16 @@
auth-renewal-cookie auth-renewal-cookie
auth-expired-cookie) auth-expired-cookie)
(struct ip-network (address prefix) #:transparent) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal data
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Holds one authenticated browser session and its two activity timestamps.
(struct session (struct session
(username [last-seen #:mutable] [last-cookie-renewal #:mutable]) (username [last-seen #:mutable] [last-cookie-renewal #:mutable])
#:transparent) #:transparent)
;;; Holds the failed-login count and start time for one client address.
(struct failures ([attempts #:mutable] [started #:mutable]) #:transparent) (struct failures ([attempts #:mutable] [started #:mutable]) #:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -32,6 +39,8 @@
; pre : Constructor fields contain normalized and parsed internal values. ; pre : Constructor fields contain normalized and parsed internal values.
; post : Creating or recognizing a value does not change external state. ; post : Creating or recognizing a value does not change external state.
; result : auth-manager? recognizes values used by the authentication API. ; result : auth-manager? recognizes values used by the authentication API.
; internals: users and trusted-proxies are immutable configuration references;
; sessions and failed hold mutable login state protected by lock.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(struct auth-manager (struct auth-manager
(users trusted-proxies session-seconds sessions failed lock) (users trusted-proxies session-seconds sessions failed lock)
@@ -52,13 +61,23 @@
(define failure-window-seconds 300) (define failure-window-seconds 300)
(define maximum-failures 5) (define maximum-failures 5)
(define ipv4-mapped-prefix
#"\0\0\0\0\0\0\0\0\0\0\377\377")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided password functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create an Argon2id password hash for configuration storage. ; goal : Create an Argon2id password hash for configuration storage.
; pre : Password is a string containing at least twelve characters. ; pre : Password is a string containing at least twelve characters.
; post : No module state is changed. ; post : No module state is changed.
; result : A salted Argon2id hash encoded as a string. ; result : A salted Argon2id hash encoded as a string.
; internals: pwhash uses password-kdf with password-parameters to generate the
; encoded hash, including its random salt and Argon2 parameters.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-password-hash password) (define/contract (make-password-hash password)
(-> string? string?)
(unless (and (string? password) (unless (and (string? password)
(>= (string-length password) 12)) (>= (string-length password) 12))
(raise-argument-error (raise-argument-error
@@ -74,151 +93,177 @@
; pre : Password and encoded are arbitrary values. ; pre : Password and encoded are arbitrary values.
; post : No module state is changed. ; post : No module state is changed.
; result : #t only when both values are strings and the password matches. ; result : #t only when both values are strings and the password matches.
; internals: pwhash-verify checks the encoded Argon2id value. Malformed hashes
; are treated as a failed match rather than escaping as exceptions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (password-hash-valid? password encoded) (define/contract (password-hash-valid? password encoded)
(and (string? password) (-> any/c any/c boolean?)
(string? encoded) (if (and (string? password) (string? encoded))
(with-handlers ((exn:fail? (lambda (_) #f))) (with-handlers ((exn:fail? (λ (_) #f)))
(pwhash-verify password-kdf (pwhash-verify password-kdf
(string->bytes/utf-8 password) (string->bytes/utf-8 password)
encoded)))) encoded))
#f))
(define (normal-ip-bytes value) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define raw ;; Supporting functions
(ip-address->bytes (make-ip-address value))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Normalize IPv4-mapped IPv6 addresses to four bytes.
(if (and (= (bytes-length raw) 16)
(for/and ((index (in-range 10)))
(zero? (bytes-ref raw index)))
(= (bytes-ref raw 10) #xff)
(= (bytes-ref raw 11) #xff))
(subbytes raw 12)
raw))
;;; Parses an address and normalizes an IPv4-mapped IPv6 value to IPv4.
(define (normal-ip-address value)
(let* ((address (make-ip-address value))
(raw (ip-address->bytes address))
(ipv4-mapped?
(and (= (bytes-length raw) 16)
(bytes=? (subbytes raw 0 12) ipv4-mapped-prefix))))
(if ipv4-mapped?
(bytes->ipv4-address (subbytes raw 12))
address)))
;;; Parses one configured IP address or CIDR value as a public net/ip network.
(define (parse-network value) (define (parse-network value)
(define parts (string-split (string-trim value) "/")) (let ((parts (string-split (string-trim value) "/")))
(unless (member (length parts) '(1 2)) (unless (member (length parts) '(1 2))
(raise-argument-error 'make-auth-manager "IP address or CIDR network" value)) (raise-argument-error
(define address 'make-auth-manager
(with-handlers ((exn:fail? "IP address or CIDR network"
(lambda (_) value))
(raise-argument-error (let* ((address
'make-auth-manager (with-handlers ((exn:fail?
"IP address or CIDR network" (λ (_)
value)))) (raise-argument-error
(normal-ip-bytes (car parts)))) 'make-auth-manager
(define maximum (* 8 (bytes-length address))) "IP address or CIDR network"
(define prefix value))))
(if (= (length parts) 2) (normal-ip-address (car parts))))
(string->number (cadr parts)) (maximum (ip-address-size address))
maximum)) (prefix
(unless (and (exact-nonnegative-integer? prefix) (if (= (length parts) 2)
(<= prefix maximum)) (string->number (cadr parts))
(raise-argument-error 'make-auth-manager "IP address or CIDR network" value)) maximum)))
(ip-network address prefix)) (unless (and (exact-nonnegative-integer? prefix)
(<= prefix maximum))
(raise-argument-error
'make-auth-manager
"IP address or CIDR network"
value))
(make-network address prefix))))
;;; Checks whether an address belongs to one configured trusted network.
(define (network-contains? network address-string) (define (network-contains? network address-string)
(with-handlers ((exn:fail? (lambda (_) #f))) (with-handlers ((exn:fail? (λ (_) #f)))
(define candidate (normal-ip-bytes address-string)) (network-member network (normal-ip-address address-string))))
(define expected (ip-network-address network))
(and (= (bytes-length candidate) (bytes-length expected))
(let-values (((whole remainder)
(quotient/remainder (ip-network-prefix network) 8)))
(and (for/and ((index (in-range whole)))
(= (bytes-ref candidate index)
(bytes-ref expected index)))
(or (zero? remainder)
(let ((mask
(bitwise-and #xff
(arithmetic-shift #xff (- remainder 8)))))
(= (bitwise-and (bytes-ref candidate whole) mask)
(bitwise-and (bytes-ref expected whole) mask)))))))))
;;; Reads one request header as a UTF-8 string when present.
(define (header-string request name) (define (header-string request name)
(let ((value (headers-assq* name (request-headers/raw request)))) (let ((value (headers-assq* name (request-headers/raw request))))
(and value (and value
(bytes->string/utf-8 (header-value value))))) (bytes->string/utf-8 (header-value value)))))
;;; Checks whether an address belongs to any configured trusted proxy network.
(define (trusted-proxy? manager address) (define (trusted-proxy? manager address)
(ormap (lambda (network) (network-contains? network address)) (ormap (λ (network) (network-contains? network address))
(auth-manager-trusted-proxies manager))) (auth-manager-trusted-proxies manager)))
;;; Resolves the effective client address, honoring only a trusted proxy header.
(define (request-address manager request) (define (request-address manager request)
(define peer (request-client-ip request)) (let* ((peer (request-client-ip request))
(define forwarded (forwarded
(and (trusted-proxy? manager peer) (and (trusted-proxy? manager peer)
(header-string request #"X-Forwarded-For"))) (header-string request #"X-Forwarded-For"))))
(if forwarded (if forwarded
;; A trusted reverse proxy appends the address it observed. Earlier ;; A trusted reverse proxy appends the address it observed. Earlier
;; values can have been supplied by the untrusted client. ;; values can have been supplied by the untrusted client.
(string-trim (last (string-split forwarded ","))) (string-trim (last (string-split forwarded ",")))
peer)) peer)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Extracts the session token from the request cookies when present.
(define (request-session-token request)
(let ((cookie
(findf
(λ (value)
(string=? (client-cookie-name value) session-cookie-name))
(request-cookies request))))
(if cookie
(client-cookie-value cookie)
#f)))
;;; Removes every browser session whose idle lifetime has elapsed.
(define (prune-sessions! manager now)
(for-each
(λ (token)
(let ((value (hash-ref (auth-manager-sessions manager) token)))
(when (> (- now (session-last-seen value))
(auth-manager-session-seconds manager))
(hash-remove! (auth-manager-sessions manager) token))))
(hash-keys (auth-manager-sessions manager))))
;;; Checks and, when necessary, resets the failure window for one address.
(define (failure-blocked? manager address now)
(let ((value (hash-ref (auth-manager-failed manager) address #f)))
(cond
((eq? value #f) #f)
((> (- now (failures-started value)) failure-window-seconds)
(hash-remove! (auth-manager-failed manager) address)
#f)
(else
(>= (failures-attempts value) maximum-failures)))))
;;; Adds one failed login to the current address window or starts a new window.
(define (record-failure! manager address now)
(let ((value (hash-ref (auth-manager-failed manager) address #f)))
(if (and value
(<= (- now (failures-started value)) failure-window-seconds))
(set-failures-attempts! value (add1 (failures-attempts value)))
(hash-set! (auth-manager-failed manager)
address
(failures 1 now)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided authentication functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Report whether browser authentication is configured. ; goal : Report whether browser authentication is configured.
; pre : Manager is an auth-manager. ; pre : Manager is an auth-manager.
; post : Manager remains unchanged. ; post : Manager remains unchanged.
; result : #t when at least one configured user can log in, otherwise #f. ; result : #t when at least one configured user can log in, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-enabled? manager) (define/contract (auth-enabled? manager)
(-> auth-manager? boolean?)
(positive? (hash-count (auth-manager-users manager)))) (positive? (hash-count (auth-manager-users manager))))
(define (request-session-token request) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(for/or ((cookie (in-list (request-cookies request))))
(and (string=? (client-cookie-name cookie) session-cookie-name)
(client-cookie-value cookie))))
(define (prune-sessions! manager now)
(for ((token (in-list (hash-keys (auth-manager-sessions manager)))))
(let ((value (hash-ref (auth-manager-sessions manager) token)))
(when (> (- now (session-last-seen value))
(auth-manager-session-seconds manager))
(hash-remove! (auth-manager-sessions manager) token)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve the browser user represented by a request cookie. ; goal : Resolve the browser user represented by a request cookie.
; pre : Manager is an auth-manager and request is an HTTP request. ; pre : Manager is an auth-manager and request is an HTTP request.
; post : Expired sessions are removed and a valid session's last-seen time ; post : Expired sessions are removed and a valid session's last-seen time
; is updated. ; is updated.
; result : "anonymous" when authentication is disabled, the normalized ; result : "anonymous" when authentication is disabled, the normalized
; username for a valid session, or #f when login is required. ; username for a valid session, or #f when login is required.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; internals: request-session-token finds the cookie. The manager lock protects
(define (auth-request-user manager request) ; prune-sessions! and the session lookup; a valid lookup updates its
(cond ; idle timestamp before returning the stored username.
((not (auth-enabled? manager)) "anonymous") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(else (define/contract (auth-request-user manager request)
(let ((token (request-session-token request)) (-> auth-manager? request? (or/c #f string?))
(now (current-seconds))) (if (not (auth-enabled? manager))
(and token "anonymous"
(let ((token (request-session-token request))
(now (current-seconds)))
(if (eq? token #f)
#f
(call-with-semaphore (call-with-semaphore
(auth-manager-lock manager) (auth-manager-lock manager)
(lambda () (λ ()
(prune-sessions! manager now) (prune-sessions! manager now)
(let ((value (hash-ref (auth-manager-sessions manager) (let ((value (hash-ref (auth-manager-sessions manager)
token token
#f))) #f)))
(and value (if value
(begin (begin
(set-session-last-seen! value now) (set-session-last-seen! value now)
(session-username value))))))))))) (session-username value))
#f))))))))
(define (failure-blocked? manager address now)
(define value (hash-ref (auth-manager-failed manager) address #f))
(and value
(if (> (- now (failures-started value)) failure-window-seconds)
(begin
(hash-remove! (auth-manager-failed manager) address)
#f)
(>= (failures-attempts value) maximum-failures))))
(define (record-failure! manager address now)
(define value (hash-ref (auth-manager-failed manager) address #f))
(if (and value
(<= (- now (failures-started value)) failure-window-seconds))
(set-failures-attempts! value (+ 1 (failures-attempts value)))
(hash-set! (auth-manager-failed manager)
address
(failures 1 now))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Authenticate credentials and start a browser session. ; goal : Authenticate credentials and start a browser session.
@@ -227,50 +272,61 @@
; post : A valid login creates a new session; a failed login updates the ; post : A valid login creates a new session; a failed login updates the
; rate-limit state for the effective client address. ; rate-limit state for the effective client address.
; result : A new opaque token, #f for invalid credentials, or 'rate-limited. ; result : A new opaque token, #f for invalid credentials, or 'rate-limited.
; internals: Unknown users follow the same Argon2id verification path as known ; internals: request-address selects the rate-limit key and failure-blocked?
; users to reduce username-dependent timing differences. ; checks its window while the manager lock is held. Unknown users
; verify against dummy-password-hash to reduce username-dependent
; timing differences. Success creates a session; failure delegates
; to record-failure!.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-login! manager request username password) (define/contract (auth-login! manager request username password)
(define address (request-address manager request)) (-> auth-manager?
(define now (current-seconds)) request?
(define normalized (string-downcase (string-trim username))) string?
(call-with-semaphore string?
(auth-manager-lock manager) (or/c #f 'rate-limited string?))
(lambda () (let ((address (request-address manager request))
(if (failure-blocked? manager address now) (now (current-seconds))
'rate-limited (normalized (string-downcase (string-trim username))))
(let* ((stored (hash-ref (auth-manager-users manager) (call-with-semaphore
normalized (auth-manager-lock manager)
#f)) (λ ()
(valid? (if (failure-blocked? manager address now)
(password-hash-valid? 'rate-limited
password (let* ((stored (hash-ref (auth-manager-users manager)
(or stored dummy-password-hash)))) normalized
(if (and stored valid?) #f))
(let ((token (valid?
(bytes->hex-string (crypto-random-bytes 32)))) (password-hash-valid?
(hash-remove! (auth-manager-failed manager) address) password
(prune-sessions! manager now) (or stored dummy-password-hash))))
(hash-set! (auth-manager-sessions manager) (if (and stored valid?)
token (let ((token
(session normalized now now)) (bytes->hex-string (crypto-random-bytes 32))))
token) (hash-remove! (auth-manager-failed manager) address)
(begin (prune-sessions! manager now)
(record-failure! manager address now) (hash-set! (auth-manager-sessions manager)
#f))))))) token
(session normalized now now))
token)
(begin
(record-failure! manager address now)
#f))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : End the browser session named by the request cookie. ; goal : End the browser session named by the request cookie.
; pre : Manager is an auth-manager and request is an HTTP request. ; pre : Manager is an auth-manager and request is an HTTP request.
; post : The matching server-side session is removed when it exists. ; post : The matching server-side session is removed when it exists.
; result : Void. ; result : Void.
; internals: request-session-token finds the cookie and the manager lock
; protects removal from the shared session hash.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-logout! manager request) (define/contract (auth-logout! manager request)
(-> auth-manager? request? void?)
(let ((token (request-session-token request))) (let ((token (request-session-token request)))
(when token (when token
(call-with-semaphore (call-with-semaphore
(auth-manager-lock manager) (auth-manager-lock manager)
(lambda () (λ ()
(hash-remove! (auth-manager-sessions manager) token)))))) (hash-remove! (auth-manager-sessions manager) token))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -279,8 +335,11 @@
; post : Manager remains unchanged. ; post : Manager remains unchanged.
; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value whose Max-Age ; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value whose Max-Age
; equals the configured session lifetime. ; equals the configured session lifetime.
; internals: format combines session-cookie-name, token and the manager's
; configured lifetime into the complete Set-Cookie header value.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-session-cookie manager token) (define/contract (auth-session-cookie manager token)
(-> auth-manager? string? bytes?)
(string->bytes/utf-8 (string->bytes/utf-8
(format (format
"~a=~a; Path=/; Max-Age=~a; Secure; HttpOnly; SameSite=Strict" "~a=~a; Path=/; Max-Age=~a; Secure; HttpOnly; SameSite=Strict"
@@ -295,38 +354,51 @@
; last-cookie-renewal time is advanced. ; last-cookie-renewal time is advanced.
; result : A fresh Set-Cookie value after half the configured lifetime has ; result : A fresh Set-Cookie value after half the configured lifetime has
; elapsed, otherwise #f. ; elapsed, otherwise #f.
; internals: The server idle timer moves on every authenticated request, while ; internals: request-session-token identifies the session. The manager lock
; this half-life threshold prevents the one-second player poll from ; protects prune-sessions! and the renewal timestamp. A half-life
; returning Set-Cookie every second. ; threshold prevents the one-second player poll from returning a
; new cookie every second.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-renewal-cookie manager request) (define/contract (auth-renewal-cookie manager request)
(and (auth-enabled? manager) (-> auth-manager? request? (or/c #f bytes?))
(let ((token (request-session-token request)) (if (not (auth-enabled? manager))
(now (current-seconds))) #f
(and token (let ((token (request-session-token request))
(call-with-semaphore (now (current-seconds)))
(auth-manager-lock manager) (if (eq? token #f)
(λ () #f
(prune-sessions! manager now) (call-with-semaphore
(define value (auth-manager-lock manager)
(hash-ref (auth-manager-sessions manager) token #f)) (λ ()
(and value (prune-sessions! manager now)
(>= (- now (session-last-cookie-renewal value)) (let ((value
(max 1 (hash-ref (auth-manager-sessions manager) token #f)))
(quotient (if value
(auth-manager-session-seconds manager) (let* ((elapsed
2))) (- now
(begin (session-last-cookie-renewal value)))
(set-session-last-cookie-renewal! value now) (renewal-interval
(auth-session-cookie manager token))))))))) (max 1
(quotient
(auth-manager-session-seconds manager)
2))))
(if (< elapsed renewal-interval)
#f
(begin
(set-session-last-cookie-renewal! value now)
(auth-session-cookie manager token))))
#f))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Encode deletion of the browser session cookie. ; goal : Encode deletion of the browser session cookie.
; pre : None. ; pre : None.
; post : No module state is changed. ; post : No module state is changed.
; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value with Max-Age 0. ; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value with Max-Age 0.
; internals: format uses session-cookie-name and an empty value to instruct the
; browser to remove the cookie immediately.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-expired-cookie) (define/contract (auth-expired-cookie)
(-> bytes?)
(string->bytes/utf-8 (string->bytes/utf-8
(format (format
"~a=; Path=/; Max-Age=0; Secure; HttpOnly; SameSite=Strict" "~a=; Path=/; Max-Age=0; Secure; HttpOnly; SameSite=Strict"
@@ -340,41 +412,50 @@
; post : No external state is changed; session and rate-limit tables start ; post : No external state is changed; session and rate-limit tables start
; empty. ; empty.
; result : A new auth-manager with normalized usernames and parsed networks. ; result : A new auth-manager with normalized usernames and parsed networks.
; internals: Each user entry is validated and copied into a case-insensitive
; hash. parse-network converts trusted-proxy-values through the
; public net/ip API; fresh hashes and a semaphore protect sessions
; and failed-login windows.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-auth-manager user-pairs (define/contract (make-auth-manager
#:trusted-proxies user-pairs
[trusted-proxy-values '("127.0.0.0/8" "::1/128")] #:trusted-proxies
#:session-seconds [session-seconds 604800]) [trusted-proxy-values '("127.0.0.0/8" "::1/128")]
#:session-seconds [session-seconds 604800])
(->* ((listof (cons/c string? string?)))
(#:trusted-proxies (listof string?)
#:session-seconds exact-positive-integer?)
auth-manager?)
(unless (exact-positive-integer? session-seconds) (unless (exact-positive-integer? session-seconds)
(raise-argument-error 'make-auth-manager "exact-positive-integer?" (raise-argument-error 'make-auth-manager "exact-positive-integer?"
session-seconds)) session-seconds))
(define users (make-hash)) (let ((users (make-hash)))
(for ((entry (in-list user-pairs))) (for-each
(unless (and (pair? entry) (λ (entry)
(string? (car entry)) (let ((username (string-trim (car entry)))
(string? (cdr entry))) (password-hash (cdr entry)))
(raise-argument-error (when (string=? username "")
'make-auth-manager (raise-arguments-error
"(listof (cons/c string? string?))" 'make-auth-manager
user-pairs)) "username must not be empty"
(when (string=? (string-trim (car entry)) "") "username" (car entry)))
(raise-arguments-error (unless (regexp-match? #px"^[$]argon2id[$]" password-hash)
'make-auth-manager (raise-arguments-error
"username must not be empty" 'make-auth-manager
"username" (car entry))) "user password is not an Argon2id hash"
(unless (regexp-match? #px"^[$]argon2id[$]" (cdr entry)) "username" (car entry)))
(raise-arguments-error (hash-set! users (string-downcase username) password-hash)))
'make-auth-manager user-pairs)
"user password is not an Argon2id hash" (auth-manager users
"username" (car entry))) (map parse-network trusted-proxy-values)
(hash-set! users (string-downcase (string-trim (car entry))) session-seconds
(cdr entry))) (make-hash)
(auth-manager users (make-hash)
(map parse-network trusted-proxy-values) (make-semaphore 1))))
session-seconds
(make-hash) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(make-hash) ;; Tests for module users.rkt
(make-semaphore 1))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test (module+ test
(require net/url (require net/url
@@ -391,6 +472,20 @@
(list (cons "Hans" test-hash)) (list (cons "Hans" test-hash))
#:trusted-proxies '("127.0.0.1/32"))) #:trusted-proxies '("127.0.0.1/32")))
(check-true
(network-contains? (parse-network "192.0.2.0/24") "192.0.2.18"))
(check-false
(network-contains? (parse-network "192.0.2.0/24") "192.0.3.18"))
(check-true
(network-contains? (parse-network "2001:db8::/32") "2001:db8::12"))
(check-true
(network-contains? (parse-network "127.0.0.0/8")
"0:0:0:0:0:ffff:7f00:1"))
(check-exn exn:fail:contract?
(λ () (parse-network "192.0.2.1/33")))
(check-exn exn:fail:contract?
(λ () (parse-network "not-an-address")))
(define (test-request peer [headers '()]) (define (test-request peer [headers '()])
(request #"GET" (string->url "http://example.test/api/state") (request #"GET" (string->url "http://example.test/api/state")
headers (delay '()) #f "127.0.0.1" 80 peer)) headers (delay '()) #f "127.0.0.1" 80 peer))
@@ -413,6 +508,13 @@
"198.51.100.2" "198.51.100.2"
(list (header #"X-Forwarded-For" #"203.0.113.9")))) (list (header #"X-Forwarded-For" #"203.0.113.9"))))
"198.51.100.2") "198.51.100.2")
(check-equal?
(request-address
manager
(test-request
"0:0:0:0:0:ffff:7f00:1"
(list (header #"X-Forwarded-For" #"203.0.113.9"))))
"203.0.113.9")
(define token (define token
(auth-login! manager remote "hans" "correct horse battery staple")) (auth-login! manager remote "hans" "correct horse battery staple"))
(check-true (string? token)) (check-true (string? token))
@@ -432,4 +534,22 @@
(check-false (auth-renewal-cookie manager authenticated)) (check-false (auth-renewal-cookie manager authenticated))
(auth-logout! manager authenticated) (auth-logout! manager authenticated)
(check-false (auth-request-user manager authenticated)) (check-false (auth-request-user manager authenticated))
(check-false (auth-login! manager remote "hans" "wrong password"))) (check-false (auth-login! manager remote "hans" "wrong password"))
(let ((limited-manager (make-auth-manager '())))
(for-each
(λ (_) (record-failure! limited-manager "192.0.2.1" 100))
(range maximum-failures))
(check-true (failure-blocked? limited-manager "192.0.2.1" 100))
(check-false
(failure-blocked? limited-manager
"192.0.2.1"
(+ 101 failure-window-seconds))))
(let ((session-manager (make-auth-manager '() #:session-seconds 10)))
(hash-set! (auth-manager-sessions session-manager)
"expired"
(session "hans" 0 0))
(prune-sessions! session-manager 11)
(check-false
(hash-has-key? (auth-manager-sessions session-manager) "expired"))))
+568 -256
View File
File diff suppressed because it is too large Load Diff
+29 -13
View File
@@ -56,20 +56,33 @@
<section class="workspace"> <section class="workspace">
<aside class="left-pane"> <aside class="left-pane">
<section class="library-pane panel"> <section id="library-pane" class="library-pane panel">
<div class="panel-header library-header"> <div class="library-tabs" role="tablist" data-i18n-aria="musicLibrary" aria-label="Music library">
<div> <button id="folders-tab" class="library-tab active" type="button" role="tab" aria-selected="true" aria-controls="folders-panel" data-i18n="folders">Folders</button>
<span class="panel-kicker" data-i18n="musicLibrary">MUSIC LIBRARY</span> <button id="saved-playlists-tab" class="library-tab" type="button" role="tab" aria-selected="false" aria-controls="saved-playlists-panel" tabindex="-1" data-i18n="playlists">Playlists</button>
<select id="library" data-i18n-aria="musicLibrary" aria-label="Music library"></select> </div>
<div id="folders-panel" class="library-folders" role="tabpanel" aria-labelledby="folders-tab">
<div class="panel-header library-header">
<div>
<span class="panel-kicker" data-i18n="musicLibrary">MUSIC LIBRARY</span>
<select id="library" data-i18n-aria="musicLibrary" aria-label="Music library"></select>
</div>
<button id="library-up" class="square-button" type="button" data-i18n-title="upFolder" title="Up one folder" aria-label="Up one folder"></button>
</div> </div>
<button id="library-up" class="square-button" type="button" data-i18n-title="upFolder" title="Up one folder" aria-label="Up one folder"></button> <nav id="breadcrumb" class="breadcrumb" data-i18n-aria="currentFolder" aria-label="Current folder"></nav>
<div id="library-empty" class="empty-state" hidden>
<p data-i18n="noLibraryConfigured">No library configured.</p>
<code>[libraries] muziek=D:\Muziek</code>
</div>
<ul id="library-entries" class="library-list" data-i18n-aria="folderContents" aria-label="Folder contents"></ul>
</div> </div>
<nav id="breadcrumb" class="breadcrumb" data-i18n-aria="currentFolder" aria-label="Current folder"></nav> <div id="saved-playlists-panel" class="library-saved" role="tabpanel" aria-labelledby="saved-playlists-tab" hidden>
<div id="library-empty" class="empty-state" hidden> <div id="saved-playlists-empty" class="empty-state">
<p data-i18n="noLibraryConfigured">No library configured.</p> <p data-i18n="noSavedPlaylists">No saved playlists yet.</p>
<code>[libraries] muziek=D:\Muziek</code> <span data-i18n="savePlaylistHint">Save a playlist tab to find it here.</span>
</div>
<ul id="saved-playlists" class="library-list" data-i18n-aria="playlists" aria-label="Playlists"></ul>
</div> </div>
<ul id="library-entries" class="library-list" data-i18n-aria="folderContents" aria-label="Folder contents"></ul>
</section> </section>
<section class="now-playing-pane panel"> <section class="now-playing-pane panel">
@@ -99,7 +112,10 @@
<span class="panel-kicker" data-i18n="playlist">PLAYLIST</span> <span class="panel-kicker" data-i18n="playlist">PLAYLIST</span>
<strong id="track-count">0 tracks</strong> <strong id="track-count">0 tracks</strong>
</div> </div>
<button id="playlist-clear" class="text-button" type="button" data-i18n="clearList">CLEAR LIST</button> <div class="playlist-actions">
<button id="playlist-save" class="text-button" type="button" data-i18n="savePlaylist">SAVE PLAYLIST</button>
<button id="playlist-clear" class="text-button" type="button" data-i18n="clearList">CLEAR LIST</button>
</div>
</div> </div>
<div id="playlist-empty" class="empty-state playlist-empty"> <div id="playlist-empty" class="empty-state playlist-empty">
@@ -151,6 +167,6 @@
</section> </section>
<script src="/translate.js" defer></script> <script src="/translate.js" defer></script>
<script src="/app.js" defer></script> <script src="/app.js" type="module"></script>
</body> </body>
</html> </html>
+4
View File
@@ -0,0 +1,4 @@
{
"private": true,
"type": "module"
}
+40
View File
@@ -0,0 +1,40 @@
/*
* Keeps the active playlist in memory between player-state requests.
* State, command and discovery requests share a queue so responses cannot
* overwrite newer state or reuse tracks from a different playlist version.
*/
export class PlayerStateClient {
#sendRequest;
#snapshot = null;
#pending = Promise.resolve();
// sendRequest performs the application's JSON GET/POST transport.
constructor(sendRequest) {
this.#sendRequest = sendRequest;
}
// Queues a state-producing request and returns a complete browser snapshot.
// A failed request does not prevent subsequent requests from being sent.
request(path, body) {
const result = this.#pending.then(() => this.#read(path, body));
this.#pending = result.catch(() => {});
return result;
}
// Sends the cached version and restores omitted tracks from that exact version.
async #read(path, body) {
if (this.#snapshot) {
path += `?playlistVersion=${encodeURIComponent(this.#snapshot.playlistVersion)}`;
}
const nextState = await this.#sendRequest(path, body);
if (nextState.tracks === null) {
if (!this.#snapshot || nextState.playlistVersion !== this.#snapshot.playlistVersion) {
this.#snapshot = null;
throw new Error("Playlist cache does not match the server version.");
}
nextState.tracks = this.#snapshot.tracks;
}
this.#snapshot = nextState;
return nextState;
}
}
+124
View File
@@ -0,0 +1,124 @@
/*
* Library view for the Folders and Playlists tabs. Saved playlists are server
* objects: actions address their UUID and reveal their existing playlist tab.
* Only the selected library view and highlighted row are local UI state.
*/
export class PlaylistLibrary {
#tabs;
#panels;
#list;
#empty;
#command;
#formatDuration;
#selectedId = null;
#signature = null;
// root owns both library panels; command sends server actions and renders state.
constructor(root, command, formatDuration) {
this.#tabs = [root.querySelector("#folders-tab"), root.querySelector("#saved-playlists-tab")];
this.#panels = [root.querySelector("#folders-panel"), root.querySelector("#saved-playlists-panel")];
this.#list = root.querySelector("#saved-playlists");
this.#empty = root.querySelector("#saved-playlists-empty");
this.#command = command;
this.#formatDuration = formatDuration;
this.#tabs.forEach((tab, index) => {
tab.addEventListener("click", () => this.show(index));
tab.addEventListener("keydown", (event) => {
if (["ArrowLeft", "ArrowRight", "Home", "End"].includes(event.key)) {
event.preventDefault();
const next = event.key === "Home" ? 0 : event.key === "End" ? 1 : 1 - index;
this.show(next);
this.#tabs[next].focus();
}
});
});
}
// Switch the library panel without changing the selected playlist or playback.
show(index) {
this.#tabs.forEach((tab, current) => {
const active = current === index;
tab.classList.toggle("active", active);
tab.setAttribute("aria-selected", String(active));
tab.tabIndex = active ? 0 : -1;
this.#panels[current].hidden = !active;
});
}
// Refresh saved playlist summaries only when metadata or language changes.
render(playlists) {
const signature = JSON.stringify([window.RktTranslate.language(), playlists]);
if (signature === this.#signature) return;
if (!playlists.some((playlist) => playlist.id === this.#selectedId)) this.#selectedId = null;
this.#list.replaceChildren(...playlists.map((playlist) => this.#createEntry(playlist)));
this.#empty.hidden = playlists.length > 0;
this.#signature = signature;
this.#select(this.#selectedId);
}
#select(id) {
this.#selectedId = id;
for (const row of this.#list.children) {
const selected = row.dataset.id === id;
row.classList.toggle("selected", selected);
row.setAttribute("aria-current", selected ? "true" : "false");
}
}
// Each action reveals this playlist by UUID; repeated opening is idempotent.
#action(label, title, playlist, play) {
const button = document.createElement("button");
button.type = "button";
button.className = "entry-action";
button.textContent = label;
button.title = title;
button.setAttribute("aria-label", title);
button.disabled = play && playlist.count === 0;
button.addEventListener("click", (event) => {
event.stopPropagation();
this.#select(playlist.id);
this.#command(play ? "playlist-play" : "playlist-open", { id: playlist.id });
});
return button;
}
#createEntry(playlist) {
const { t } = window.RktTranslate;
const row = document.createElement("li");
row.className = "library-entry";
row.dataset.id = playlist.id;
row.tabIndex = 0;
const icon = document.createElement("span");
icon.className = "entry-icon";
icon.textContent = "♫";
const name = document.createElement("span");
name.className = "entry-name";
name.textContent = playlist.name;
name.title = playlist.name;
const details = document.createElement("small");
details.className = "entry-details";
details.textContent = `${playlist.count} ${t(playlist.count === 1 ? "oneTrack" : "manyTracks")}, ${this.#formatDuration(playlist.duration)}`;
name.append(details);
const actions = document.createElement("span");
actions.className = "entry-actions";
actions.append(
this.#action("▶", t("playNow", { name: playlist.name }), playlist, true),
this.#action("", t("openPlaylistNamed", { name: playlist.name }), playlist, false),
);
row.append(icon, name, actions);
row.addEventListener("click", () => this.#select(playlist.id));
row.addEventListener("dblclick", (event) => {
if (event.target.closest("button")) return;
this.#command("playlist-open", { id: playlist.id });
});
row.addEventListener("keydown", (event) => {
if (event.target !== row) return;
if (["Enter", "+", " "].includes(event.key)) {
event.preventDefault();
this.#select(playlist.id);
if (event.key !== " ") this.#command("playlist-open", { id: playlist.id });
}
});
return row;
}
}
Binary file not shown.

After

Width:  |  Height:  |  Size: 60 KiB

+61 -2
View File
@@ -332,10 +332,61 @@ input[type="range"] {
.library-pane { .library-pane {
display: grid; display: grid;
grid-template-rows: auto auto minmax(0, 1fr); grid-template-rows: auto minmax(0, 1fr);
border-bottom: 0; border-bottom: 0;
} }
.library-tabs {
display: flex;
border-bottom: 1px solid var(--line-soft);
}
.library-tab {
flex: 1;
min-height: 36px;
border: 0;
background: transparent;
color: var(--muted);
font-size: 12px;
}
.library-tab.active {
color: var(--accent);
box-shadow: inset 0 -2px var(--accent);
}
.library-folders {
display: grid;
grid-template-rows: auto auto minmax(0, 1fr);
min-height: 0;
}
.library-saved {
display: grid;
min-height: 0;
}
.library-folders[hidden],
.library-saved[hidden] {
display: none;
}
.library-saved > .library-list,
.library-saved > .empty-state {
grid-area: 1 / 1;
}
.library-entry.selected {
background: var(--panel-raised);
}
.entry-details {
display: block;
margin-top: 3px;
color: var(--muted);
font-size: 10px;
}
.panel-header { .panel-header {
min-height: 55px; min-height: 55px;
padding: 8px 10px; padding: 8px 10px;
@@ -601,6 +652,8 @@ input[type="range"] {
.playlist-toolbar { .playlist-toolbar {
justify-content: space-between; justify-content: space-between;
flex-wrap: wrap;
gap: 8px;
min-height: 53px; min-height: 53px;
padding: 8px 12px; padding: 8px 12px;
border-bottom: 1px solid var(--line-soft); border-bottom: 1px solid var(--line-soft);
@@ -611,6 +664,12 @@ input[type="range"] {
gap: 4px; gap: 4px;
} }
.playlist-toolbar > .playlist-actions {
display: flex;
flex-wrap: wrap;
gap: 6px;
}
.playlist-toolbar strong { .playlist-toolbar strong {
font-size: 14px; font-size: 14px;
} }
@@ -739,7 +798,7 @@ input[type="range"] {
align-self: center; align-self: center;
} }
.library-pane > .empty-state { .library-folders > .empty-state {
grid-row: 3; grid-row: 3;
z-index: 2; z-index: 2;
} }
+140
View File
@@ -3,6 +3,14 @@
const translations = { const translations = {
en: { en: {
folders: "Folders",
savePlaylist: "SAVE PLAYLIST",
playlistSaved: "SAVED",
noSavedPlaylists: "No saved playlists yet.",
savePlaylistHint: "Save a playlist tab to find it here.",
openPlaylistNamed: "Open {name} as a tab",
closePlaylist: "Close tab",
playingTime: "{duration} playing time",
output: "OUTPUT", searchPlayers: "Search for network players", logout: "LOG OUT", output: "OUTPUT", searchPlayers: "Search for network players", logout: "LOG OUT",
rendererLocal: "LOCAL", defaultPlaylist: "Default", rendererLocal: "LOCAL", defaultPlaylist: "Default",
playbackControls: "Playback controls", previousTrack: "Previous track", playbackControls: "Playback controls", previousTrack: "Previous track",
@@ -25,8 +33,22 @@
channels: "channels", oneChannel: "channel", searchingPlayers: "Searching for network players…", channels: "channels", oneChannel: "channel", searchingPlayers: "Searching for network players…",
authUnknown: "Authentication status unknown: {message}", noConnection: "No connection: {message}", authUnknown: "Authentication status unknown: {message}", noConnection: "No connection: {message}",
loggedOut: "You have been logged out.", volumePercent: "Set volume, {value} percent", loggedOut: "You have been logged out.", volumePercent: "Set volume, {value} percent",
"login-rate-limited": "Too many failed sign-in attempts; try again in a few minutes.",
"invalid-credentials": "Invalid username or password.",
"json-required": "Content-Type application/json is required.",
"authentication-required": "Sign-in is required.",
"dlna-renderer-no-start-of-track-confirmation": "The DLNA renderer did not confirm the start of the track.",
"dlna-renderer-unreachable": "The DLNA renderer is unreachable.",
}, },
nl: { nl: {
folders: "Mappen",
savePlaylist: "AFSPEELLIJST OPSLAAN",
playlistSaved: "OPGESLAGEN",
noSavedPlaylists: "Nog geen opgeslagen afspeellijsten.",
savePlaylistHint: "Sla een playlisttab op om hem hier terug te vinden.",
openPlaylistNamed: "{name} als tab openen",
closePlaylist: "Tab sluiten",
playingTime: "{duration} speeltijd",
output: "UITVOER", searchPlayers: "Netwerkspelers zoeken", logout: "UITLOGGEN", output: "UITVOER", searchPlayers: "Netwerkspelers zoeken", logout: "UITLOGGEN",
rendererLocal: "LOKAAL", defaultPlaylist: "Standaard", rendererLocal: "LOKAAL", defaultPlaylist: "Standaard",
playbackControls: "Afspeelbediening", previousTrack: "Vorige track", playbackControls: "Afspeelbediening", previousTrack: "Vorige track",
@@ -49,8 +71,22 @@
channels: "kanalen", oneChannel: "kanaal", searchingPlayers: "Netwerkspelers zoeken…", channels: "kanalen", oneChannel: "kanaal", searchingPlayers: "Netwerkspelers zoeken…",
authUnknown: "Authenticatiestatus onbekend: {message}", noConnection: "Geen verbinding: {message}", authUnknown: "Authenticatiestatus onbekend: {message}", noConnection: "Geen verbinding: {message}",
loggedOut: "Je bent uitgelogd.", volumePercent: "Volume instellen, {value} procent", loggedOut: "Je bent uitgelogd.", volumePercent: "Volume instellen, {value} procent",
"login-rate-limited": "Te veel mislukte aanmeldpogingen; probeer het over enkele minuten opnieuw.",
"invalid-credentials": "Ongeldige gebruikersnaam of ongeldig wachtwoord.",
"json-required": "Content-Type application/json is vereist.",
"authentication-required": "Aanmelden is vereist.",
"dlna-renderer-no-start-of-track-confirmation": "De DLNA-renderer bevestigde de start van de track niet.",
"dlna-renderer-unreachable": "De DLNA-renderer is niet bereikbaar.",
}, },
de: { de: {
folders: "Ordner",
savePlaylist: "WIEDERGABELISTE SPEICHERN",
playlistSaved: "GESPEICHERT",
noSavedPlaylists: "Noch keine gespeicherten Wiedergabelisten.",
savePlaylistHint: "Speichern Sie eine Wiedergabeliste, um sie hier zu finden.",
openPlaylistNamed: "{name} als Tab öffnen",
closePlaylist: "Tab schließen",
playingTime: "{duration} Spielzeit",
output: "AUSGABE", searchPlayers: "Netzwerkplayer suchen", logout: "ABMELDEN", output: "AUSGABE", searchPlayers: "Netzwerkplayer suchen", logout: "ABMELDEN",
rendererLocal: "LOKAL", defaultPlaylist: "Standard", rendererLocal: "LOKAL", defaultPlaylist: "Standard",
playbackControls: "Wiedergabesteuerung", previousTrack: "Vorheriger Titel", playbackControls: "Wiedergabesteuerung", previousTrack: "Vorheriger Titel",
@@ -73,8 +109,22 @@
channels: "Kanäle", oneChannel: "Kanal", searchingPlayers: "Netzwerkplayer werden gesucht…", channels: "Kanäle", oneChannel: "Kanal", searchingPlayers: "Netzwerkplayer werden gesucht…",
authUnknown: "Authentifizierungsstatus unbekannt: {message}", noConnection: "Keine Verbindung: {message}", authUnknown: "Authentifizierungsstatus unbekannt: {message}", noConnection: "Keine Verbindung: {message}",
loggedOut: "Sie wurden abgemeldet.", volumePercent: "Lautstärke einstellen, {value} Prozent", loggedOut: "Sie wurden abgemeldet.", volumePercent: "Lautstärke einstellen, {value} Prozent",
"login-rate-limited": "Zu viele fehlgeschlagene Anmeldeversuche; versuchen Sie es in einigen Minuten erneut.",
"invalid-credentials": "Ungültiger Benutzername oder ungültiges Passwort.",
"json-required": "Content-Type application/json ist erforderlich.",
"authentication-required": "Eine Anmeldung ist erforderlich.",
"dlna-renderer-no-start-of-track-confirmation": "Der DLNA-Renderer hat den Start des Titels nicht bestätigt.",
"dlna-renderer-unreachable": "Der DLNA-Renderer ist nicht erreichbar.",
}, },
fr: { fr: {
folders: "Dossiers",
savePlaylist: "ENREGISTRER LA LISTE",
playlistSaved: "ENREGISTRÉE",
noSavedPlaylists: "Aucune liste de lecture enregistrée.",
savePlaylistHint: "Enregistrez une liste de lecture pour la retrouver ici.",
openPlaylistNamed: "Ouvrir {name} dans un onglet",
closePlaylist: "Fermer longlet",
playingTime: "{duration} de lecture",
output: "SORTIE", searchPlayers: "Rechercher les lecteurs réseau", logout: "DÉCONNEXION", output: "SORTIE", searchPlayers: "Rechercher les lecteurs réseau", logout: "DÉCONNEXION",
rendererLocal: "LOCAL", defaultPlaylist: "Par défaut", rendererLocal: "LOCAL", defaultPlaylist: "Par défaut",
playbackControls: "Commandes de lecture", previousTrack: "Piste précédente", playbackControls: "Commandes de lecture", previousTrack: "Piste précédente",
@@ -97,8 +147,22 @@
channels: "canaux", oneChannel: "canal", searchingPlayers: "Recherche des lecteurs réseau…", channels: "canaux", oneChannel: "canal", searchingPlayers: "Recherche des lecteurs réseau…",
authUnknown: "État dauthentification inconnu : {message}", noConnection: "Aucune connexion : {message}", authUnknown: "État dauthentification inconnu : {message}", noConnection: "Aucune connexion : {message}",
loggedOut: "Vous avez été déconnecté.", volumePercent: "Régler le volume, {value} pour cent", loggedOut: "Vous avez été déconnecté.", volumePercent: "Régler le volume, {value} pour cent",
"login-rate-limited": "Trop de tentatives de connexion ont échoué ; réessayez dans quelques minutes.",
"invalid-credentials": "Nom dutilisateur ou mot de passe incorrect.",
"json-required": "Le Content-Type application/json est requis.",
"authentication-required": "La connexion est requise.",
"dlna-renderer-no-start-of-track-confirmation": "Le lecteur DLNA na pas confirmé le démarrage de la piste.",
"dlna-renderer-unreachable": "Le lecteur DLNA est inaccessible.",
}, },
es: { es: {
folders: "Carpetas",
savePlaylist: "GUARDAR LISTA",
playlistSaved: "GUARDADA",
noSavedPlaylists: "Todavía no hay listas guardadas.",
savePlaylistHint: "Guarda una lista de reproducción para encontrarla aquí.",
openPlaylistNamed: "Abrir {name} en una pestaña",
closePlaylist: "Cerrar pestaña",
playingTime: "{duration} de reproducción",
output: "SALIDA", searchPlayers: "Buscar reproductores de red", logout: "CERRAR SESIÓN", output: "SALIDA", searchPlayers: "Buscar reproductores de red", logout: "CERRAR SESIÓN",
rendererLocal: "LOCAL", defaultPlaylist: "Predeterminada", rendererLocal: "LOCAL", defaultPlaylist: "Predeterminada",
playbackControls: "Controles de reproducción", previousTrack: "Pista anterior", playbackControls: "Controles de reproducción", previousTrack: "Pista anterior",
@@ -121,8 +185,22 @@
channels: "canales", oneChannel: "canal", searchingPlayers: "Buscando reproductores de red…", channels: "canales", oneChannel: "canal", searchingPlayers: "Buscando reproductores de red…",
authUnknown: "Estado de autenticación desconocido: {message}", noConnection: "Sin conexión: {message}", authUnknown: "Estado de autenticación desconocido: {message}", noConnection: "Sin conexión: {message}",
loggedOut: "Has cerrado la sesión.", volumePercent: "Ajustar volumen, {value} por ciento", loggedOut: "Has cerrado la sesión.", volumePercent: "Ajustar volumen, {value} por ciento",
"login-rate-limited": "Demasiados intentos de inicio de sesión fallidos; inténtalo de nuevo en unos minutos.",
"invalid-credentials": "Nombre de usuario o contraseña no válidos.",
"json-required": "Se requiere Content-Type application/json.",
"authentication-required": "Es necesario iniciar sesión.",
"dlna-renderer-no-start-of-track-confirmation": "El renderizador DLNA no confirmó el inicio de la pista.",
"dlna-renderer-unreachable": "No se puede acceder al renderizador DLNA.",
}, },
it: { it: {
folders: "Cartelle",
savePlaylist: "SALVA PLAYLIST",
playlistSaved: "SALVATA",
noSavedPlaylists: "Nessuna playlist salvata.",
savePlaylistHint: "Salva una playlist per ritrovarla qui.",
openPlaylistNamed: "Apri {name} in una scheda",
closePlaylist: "Chiudi scheda",
playingTime: "{duration} di riproduzione",
output: "USCITA", searchPlayers: "Cerca lettori di rete", logout: "ESCI", output: "USCITA", searchPlayers: "Cerca lettori di rete", logout: "ESCI",
rendererLocal: "LOCALE", defaultPlaylist: "Predefinita", rendererLocal: "LOCALE", defaultPlaylist: "Predefinita",
playbackControls: "Controlli di riproduzione", previousTrack: "Traccia precedente", playbackControls: "Controlli di riproduzione", previousTrack: "Traccia precedente",
@@ -145,8 +223,22 @@
channels: "canali", oneChannel: "canale", searchingPlayers: "Ricerca dei lettori di rete…", channels: "canali", oneChannel: "canale", searchingPlayers: "Ricerca dei lettori di rete…",
authUnknown: "Stato di autenticazione sconosciuto: {message}", noConnection: "Nessuna connessione: {message}", authUnknown: "Stato di autenticazione sconosciuto: {message}", noConnection: "Nessuna connessione: {message}",
loggedOut: "Hai effettuato la disconnessione.", volumePercent: "Regola il volume, {value} percento", loggedOut: "Hai effettuato la disconnessione.", volumePercent: "Regola il volume, {value} percento",
"login-rate-limited": "Troppi tentativi di accesso non riusciti; riprova tra qualche minuto.",
"invalid-credentials": "Nome utente o password non validi.",
"json-required": "È richiesto Content-Type application/json.",
"authentication-required": "È necessario effettuare laccesso.",
"dlna-renderer-no-start-of-track-confirmation": "Il renderer DLNA non ha confermato lavvio della traccia.",
"dlna-renderer-unreachable": "Il renderer DLNA non è raggiungibile.",
}, },
sv: { sv: {
folders: "Mappar",
savePlaylist: "SPARA SPELLISTA",
playlistSaved: "SPARAD",
noSavedPlaylists: "Inga sparade spellistor ännu.",
savePlaylistHint: "Spara en spellista för att hitta den här.",
openPlaylistNamed: "Öppna {name} som en flik",
closePlaylist: "Stäng fliken",
playingTime: "{duration} speltid",
output: "UTGÅNG", searchPlayers: "Sök efter nätverksspelare", logout: "LOGGA UT", output: "UTGÅNG", searchPlayers: "Sök efter nätverksspelare", logout: "LOGGA UT",
rendererLocal: "LOKAL", defaultPlaylist: "Standard", rendererLocal: "LOKAL", defaultPlaylist: "Standard",
playbackControls: "Uppspelningskontroller", previousTrack: "Föregående spår", playbackControls: "Uppspelningskontroller", previousTrack: "Föregående spår",
@@ -169,8 +261,22 @@
channels: "kanaler", oneChannel: "kanal", searchingPlayers: "Söker efter nätverksspelare…", channels: "kanaler", oneChannel: "kanal", searchingPlayers: "Söker efter nätverksspelare…",
authUnknown: "Okänd autentiseringsstatus: {message}", noConnection: "Ingen anslutning: {message}", authUnknown: "Okänd autentiseringsstatus: {message}", noConnection: "Ingen anslutning: {message}",
loggedOut: "Du har loggats ut.", volumePercent: "Ställ in volymen på {value} procent", loggedOut: "Du har loggats ut.", volumePercent: "Ställ in volymen på {value} procent",
"login-rate-limited": "För många misslyckade inloggningsförsök; försök igen om några minuter.",
"invalid-credentials": "Ogiltigt användarnamn eller lösenord.",
"json-required": "Content-Type application/json krävs.",
"authentication-required": "Inloggning krävs.",
"dlna-renderer-no-start-of-track-confirmation": "DLNA-renderaren bekräftade inte att spåret startade.",
"dlna-renderer-unreachable": "DLNA-renderaren kan inte nås.",
}, },
no: { no: {
folders: "Mapper",
savePlaylist: "LAGRE SPILLELISTE",
playlistSaved: "LAGRET",
noSavedPlaylists: "Ingen lagrede spillelister ennå.",
savePlaylistHint: "Lagre en spilleliste for å finne den her.",
openPlaylistNamed: "Åpne {name} som en fane",
closePlaylist: "Lukk fanen",
playingTime: "{duration} spilletid",
output: "UTGANG", searchPlayers: "Søk etter nettverksspillere", logout: "LOGG UT", output: "UTGANG", searchPlayers: "Søk etter nettverksspillere", logout: "LOGG UT",
rendererLocal: "LOKAL", defaultPlaylist: "Standard", rendererLocal: "LOKAL", defaultPlaylist: "Standard",
playbackControls: "Avspillingskontroller", previousTrack: "Forrige spor", playbackControls: "Avspillingskontroller", previousTrack: "Forrige spor",
@@ -193,8 +299,22 @@
channels: "kanaler", oneChannel: "kanal", searchingPlayers: "Søker etter nettverksspillere…", channels: "kanaler", oneChannel: "kanal", searchingPlayers: "Søker etter nettverksspillere…",
authUnknown: "Ukjent autentiseringsstatus: {message}", noConnection: "Ingen tilkobling: {message}", authUnknown: "Ukjent autentiseringsstatus: {message}", noConnection: "Ingen tilkobling: {message}",
loggedOut: "Du er logget ut.", volumePercent: "Still inn volumet på {value} prosent", loggedOut: "Du er logget ut.", volumePercent: "Still inn volumet på {value} prosent",
"login-rate-limited": "For mange mislykkede innloggingsforsøk; prøv igjen om noen minutter.",
"invalid-credentials": "Ugyldig brukernavn eller passord.",
"json-required": "Content-Type application/json er påkrevd.",
"authentication-required": "Innlogging er påkrevd.",
"dlna-renderer-no-start-of-track-confirmation": "DLNA-gjengiveren bekreftet ikke at sporet startet.",
"dlna-renderer-unreachable": "DLNA-gjengiveren kan ikke nås.",
}, },
fi: { fi: {
folders: "Kansiot",
savePlaylist: "TALLENNA SOITTOLISTA",
playlistSaved: "TALLENNETTU",
noSavedPlaylists: "Ei vielä tallennettuja soittolistoja.",
savePlaylistHint: "Tallenna soittolista, niin löydät sen täältä.",
openPlaylistNamed: "Avaa {name} välilehtenä",
closePlaylist: "Sulje välilehti",
playingTime: "Toistoaika: {duration}",
output: "ULOSTULO", searchPlayers: "Etsi verkkosoittimia", logout: "KIRJAUDU ULOS", output: "ULOSTULO", searchPlayers: "Etsi verkkosoittimia", logout: "KIRJAUDU ULOS",
rendererLocal: "PAIKALLINEN", defaultPlaylist: "Oletus", rendererLocal: "PAIKALLINEN", defaultPlaylist: "Oletus",
playbackControls: "Toiston ohjaimet", previousTrack: "Edellinen kappale", playbackControls: "Toiston ohjaimet", previousTrack: "Edellinen kappale",
@@ -217,8 +337,22 @@
channels: "kanavaa", oneChannel: "kanava", searchingPlayers: "Etsitään verkkosoittimia…", channels: "kanavaa", oneChannel: "kanava", searchingPlayers: "Etsitään verkkosoittimia…",
authUnknown: "Todennuksen tila ei ole tiedossa: {message}", noConnection: "Ei yhteyttä: {message}", authUnknown: "Todennuksen tila ei ole tiedossa: {message}", noConnection: "Ei yhteyttä: {message}",
loggedOut: "Olet kirjautunut ulos.", volumePercent: "Säädä äänenvoimakkuudeksi {value} prosenttia", loggedOut: "Olet kirjautunut ulos.", volumePercent: "Säädä äänenvoimakkuudeksi {value} prosenttia",
"login-rate-limited": "Liian monta epäonnistunutta kirjautumisyritystä; yritä uudelleen muutaman minuutin kuluttua.",
"invalid-credentials": "Virheellinen käyttäjänimi tai salasana.",
"json-required": "Content-Type application/json vaaditaan.",
"authentication-required": "Kirjautuminen vaaditaan.",
"dlna-renderer-no-start-of-track-confirmation": "DLNA-toistin ei vahvistanut kappaleen käynnistymistä.",
"dlna-renderer-unreachable": "DLNA-toistimeen ei saada yhteyttä.",
}, },
is: { is: {
folders: "Möppur",
savePlaylist: "VISTA SPILUNARLISTA",
playlistSaved: "VISTAÐ",
noSavedPlaylists: "Engir vistaðir spilunarlistar enn.",
savePlaylistHint: "Vistaðu spilunarlista til að finna hann hér.",
openPlaylistNamed: "Opna {name} í flipa",
closePlaylist: "Loka flipa",
playingTime: "Spilunartími: {duration}",
output: "ÚTTAK", searchPlayers: "Leita að netspilurum", logout: "SKRÁ ÚT", output: "ÚTTAK", searchPlayers: "Leita að netspilurum", logout: "SKRÁ ÚT",
rendererLocal: "STAÐBUNDIÐ", defaultPlaylist: "Sjálfgefið", rendererLocal: "STAÐBUNDIÐ", defaultPlaylist: "Sjálfgefið",
playbackControls: "Stýringar spilunar", previousTrack: "Fyrra lag", playbackControls: "Stýringar spilunar", previousTrack: "Fyrra lag",
@@ -241,6 +375,12 @@
channels: "rásir", oneChannel: "rás", searchingPlayers: "Leita að netspilurum…", channels: "rásir", oneChannel: "rás", searchingPlayers: "Leita að netspilurum…",
authUnknown: "Staða auðkenningar óþekkt: {message}", noConnection: "Engin tenging: {message}", authUnknown: "Staða auðkenningar óþekkt: {message}", noConnection: "Engin tenging: {message}",
loggedOut: "Þú hefur skráð þig út.", volumePercent: "Stilla hljóðstyrk á {value} prósent", loggedOut: "Þú hefur skráð þig út.", volumePercent: "Stilla hljóðstyrk á {value} prósent",
"login-rate-limited": "Of margar misheppnaðar innskráningartilraunir; reyndu aftur eftir nokkrar mínútur.",
"invalid-credentials": "Ógilt notandanafn eða lykilorð.",
"json-required": "Content-Type application/json er áskilið.",
"authentication-required": "Innskráningar er krafist.",
"dlna-renderer-no-start-of-track-confirmation": "DLNA-spilarinn staðfesti ekki að spilun lagsins hefði hafist.",
"dlna-renderer-unreachable": "Ekki næst samband við DLNA-spilarann.",
}, },
}; };
+7
View File
@@ -6,6 +6,7 @@ port=8080
dlna-port=8734 dlna-port=8734
; Set to false when the server itself must not appear as an audio output. ; Set to false when the server itself must not appear as an audio output.
local-output=true local-output=true
; playlist-keystore=./data/playlists.keystore
[libraries] [libraries]
; muziek=D:\Muziek ; muziek=D:\Muziek
@@ -29,3 +30,9 @@ session-seconds=604800
; ;
; hans=$argon2id$v=19$m=19456,t=2,p=1$... ; hans=$argon2id$v=19$m=19456,t=2,p=1$...
; ;
[logging]
; log-file=./data/rkt-web-player.log
; log-retention-days=7
; log-level=debug
+247 -8
View File
@@ -4,17 +4,125 @@
racket/contract racket/contract
rkt-web-player rkt-web-player
rkt-web-player/player-agent rkt-web-player/player-agent
rkt-web-player/set-user
rkt-web-player/users)) rkt-web-player/users))
@title{RKT Web Player} @title{RKT Web Player}
@author{Hans van Dijkema} @author[@author+email["Hans Dijkema" "hans@dijkewijk.nl"]]
@defmodule[rkt-web-player] @defmodule[rkt-web-player]
RKT Web Player combines local playback through @tt{racket-audio} RKT Web Player is a central music server for a trusted network. It makes one
with UPnP and Sonos discovery and playback through or more configured music libraries available through a web interface and
@tt{racket-audio-dlna}. The user interface is served to a web plays that music on different kinds of renderers: the server's own audio
browser by Racket's web server. device, UPnP devices, Sonos groups, and player agents. The package also
provides those player agents as GUI and headless CLI applications, so a
computer without UPnP support can become a network renderer of its own. The
central server and each agent communicate over HTTP; the agent downloads its
assigned tracks and plays them on its local audio device.
@section{What the player provides}
The central server is the heart of the application. Its main features are:
@itemlist[
@item{Multiple named music libraries, including local and UNC/network paths.}
@item{Lazy directory browsing: startup reads only the library roots, while
recursive contents and audio metadata are read when needed.}
@item{Playback of the central library through the server's local audio
device, discovered UPnP renderers, Sonos groups, or registered agents.}
@item{Playlist tabs with adding, removing, reordering, renaming and
drag-and-drop support. Tracks from different libraries can share a
playlist. The playlist toolbar shows the selected playlist's track count
and total known playing time, rounded to minutes and expressed in hours
and minutes. Tracks without duration metadata contribute zero to the total.}
@item{Gapless network playback where the renderer or playback agent supports
preloading the next track, with a server-side fallback.}
@item{Transport controls, seeking, volume, repeat mode and live playback
status.}
@item{Embedded album art and adjacent @tt{cover}, @tt{folder} and
@tt{front} JPEG/PNG artwork.}
@item{Per-user playlists, language preference and playback pipeline, with
shared physical outputs that can be transferred between users.}
@item{Dutch, English, German, French, Spanish, Italian, Swedish, Norwegian,
Finnish and Icelandic interfaces.}
@item{Optional Argon2id browser authentication and a separate default-deny
allowlist for playback agents.}
]
The browser is a thin remote control, not a second player. It polls player
status once per second and sends commands to the central server;
playlists, preferences and playback state are kept there. The server exposes
the browser application under the root URL and its JSON API under @tt{/api}.
The API includes state, discovery, playback commands, preferences, artwork and
the agent registration, polling and media routes.
@subsection{Playlist synchronization}
State responses include an opaque @tt{playlistVersion} for the selected
playlist. The browser sends its last received version as the
@tt{playlistVersion} query parameter on @tt{/api/state}, @tt{/api/discover}
and @tt{/api/command/}@italic{command}. When that version still matches,
@tt{tracks} is JSON @tt{null}; otherwise the response includes the complete
track array. Requests without a version continue to receive all tracks.
The version and track data are returned together in one consistent snapshot.
The server caches serialized tracks, count and total duration per playlist.
Changing the track list invalidates that snapshot and generates a fresh version
when it is next requested. Renaming a tab or updating playback position does
not invalidate the tracks. Versions are renewed after a server restart and
are distinct between playlists and users. Changes from another browser are
picked up by the next poll.
The browser keeps the active playlist in memory and serializes state-producing
requests through @tt{PlayerStateClient}, so a delayed response cannot replace
newer state. Unchanged playlist rows are reused; changing the interface language
still rebuilds their translated labels.
@subsection{Saved playlists in the library}
The library has @italic{Folders} and @italic{Playlists} tabs. The playlist
toolbar's @italic{Save playlist} button names and saves the current tab in
the user's library. The library row's @tt{} button opens that playlist as
its own tab, or selects its existing tab. @tt{▶} does the same and starts
playback. These actions never append tracks to or replace another tab.
A saved playlist and its open tab share one UUID and one track list. Track
edits and renaming therefore update the saved playlist automatically. Closing
the tab keeps it in the library. Closing the last saved tab leaves a new empty
default tab. Existing tabs remain open and appear in the library only after
the user explicitly saves them.
The keystore retains @tt{playlists-for-}@italic{username} for the ordered open
tabs and adds @tt{saved-playlists-for-}@italic{username} for library playlists.
Each UUID has one stored value, shared by both indexes. The private storage
procedure @tt{load-user-playlists} reads the open index by default and the saved
index with @tt{#:saved? #t}. @tt{save-user-playlists!} accepts the saved collection
through @tt{#:saved} and updates both indexes atomically. Values absent from
both indexes are removed. Legacy stores without a saved index need no migration.
Browser state includes @tt{savedPlaylists} summaries without track arrays and
a @tt{saved} flag on each tab. @tt{playlist-save} takes an open tab's @tt{id}
and a @tt{name}; @tt{playlist-open} and @tt{playlist-play} take a saved playlist's
@tt{id}. All three commands operate within the requesting user's collection.
@subsection{Player agents}
A player agent is an additional renderer implemented by this package. It runs
on a computer connected to speakers, registers with the central server, polls
for commands, downloads the selected music and plays it locally. Agents do not
open an inbound network port. The package supplies two forms:
@itemlist[
@item{The GUI agent, with a desktop window and system-tray integration.}
@item{The headless CLI agent, suitable for a small always-on computer or a
machine without a graphical desktop.}
]
The server treats each registered agent as an output alongside UPnP and Sonos
renderers. The server can prefetch the next track to an agent for gapless
transitions. A 256-bit application ID identifies the agent; the server's
@tt{[playback-agents]} allowlist decides which agents may connect.
@defproc[(run-web-player @defproc[(run-web-player
[music-paths (listof (or/c path-string? [music-paths (listof (or/c path-string?
@@ -28,7 +136,10 @@ browser by Racket's web server.
[#:dlna-port dlna-port exact-positive-integer? 8734] [#:dlna-port dlna-port exact-positive-integer? 8734]
[#:local-output? local-output? boolean? #t] [#:local-output? local-output? boolean? #t]
[#:playlist-keystore playlist-keystore (or/c path-string? #f)] [#:playlist-keystore playlist-keystore (or/c path-string? #f)]
[#:launch-browser? launch-browser? boolean? #t]) any/c] { [#:log-file log-file path-string?]
[#:log-retention-days log-retention-days exact-positive-integer? 7]
[#:log-level log-level symbol? 'debug]
[#:launch-browser? launch-browser? boolean? #t]) any/c]{
Treats every entry in @racket[music-paths] as a separate music library. A Treats every entry in @racket[music-paths] as a separate music library. A
two-element list supplies an explicit display name and path. The two-element list supplies an explicit display name and path. The
@@ -59,10 +170,127 @@ Sessions have a sliding idle timeout; an active browser cookie is renewed once
half of @racket[session-seconds] has elapsed. Playback-agent endpoints continue half of @racket[session-seconds] has elapsed. Playback-agent endpoints continue
to use their separate application-ID allowlist. to use their separate application-ID allowlist.
Logging is written to @racket[log-file]. Files are rotated after
@racket[log-retention-days] days, and @racket[log-level] selects the
@tt{simple-log} level. The default log file is
@tt{data/rkt-web-player.log} below the installed collection. The
@racket[playlist-keystore], @racket[log-file] and @racket[log-level] arguments
are useful when embedding the player; the command-line entry point can also
read these values from an INI file.
The default listen address only exposes the interface to the local computer. The default listen address only exposes the interface to the local computer.
Use a LAN address deliberately if other devices should control the player. Use a LAN address deliberately if other devices should control the player.
} }
@section{Command line and INI configuration}
The package entry point accepts one or more music directories:
@verbatim{
racket main.rkt MUSIC-DIRECTORY [...]
racket main.rkt --config rkt-web-player.ini --no-browser
}
The @tt{--config} option reads defaults from an INI file. The file is normally
named @tt{rkt-web-player.ini} and is read from the current directory when the
server is started with @tt{--config}. Relative paths are interpreted in the
process's working directory.
Command-line values for @tt{--listen-ip}, @tt{--port}, @tt{--dlna-port},
@tt{--playlist-keystore}, @tt{--log-file} and @tt{--no-browser} override the
corresponding defaults. Logging retention, log level, authentication and the
playback-agent allowlist are configured in the INI file. Libraries configured
under @tt{[libraries]} use the INI key as their display name and the value as
the root directory. The legacy @tt{[library] paths} setting accepts a
semicolon-separated list and is also supported. A complete example is:
@verbatim{
[server]
listen-ip=127.0.0.1
port=8080
[player]
dlna-port=8734
local-output=true
playlist-keystore=data/playlists.keystore
[logging]
log-file=data/rkt-web-player.log
log-retention-days=7
log-level=debug
[authentication]
trusted-proxies=127.0.0.0/8;::1/128
session-seconds=604800
[playback-agents]
; 64 hexadecimal characters, copied from an agent
0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef=true
[users]
; Generate hashes with make-password-hash or set-user.
hans=$argon2id$v=19$m=19456,t=2,p=1$...
}
The @tt{[server]} section controls the browser server. The default
@tt{listen-ip} is @tt{127.0.0.1}, so the interface is local-only by default;
@tt{0.0.0.0} or a LAN address makes it reachable from other machines.
@tt{port} defaults to @tt{8080}.
The @tt{[player]} section controls playback. @tt{dlna-port} defaults to
@tt{8734} and must be reachable by network renderers when they play files
published by the server. @tt{local-output=true} (the default) adds the
server's own audio device as an output. @tt{playlist-keystore} selects the
keystore for playlist tabs and language preferences; omission uses
@tt{data/playlists.keystore} below the installed collection. When embedding
the player through @racket[run-web-player], passing @racket[#f] disables
persistence.
The @tt{[logging]} section controls the rotating log file. The default file is
@tt{data/rkt-web-player.log}, retention defaults to seven days, and the default
level is @tt{debug}. The level is passed to @tt{simple-log}; use a level
supported by that package.
The @tt{[playback-agents]} section is a default-deny allowlist. Each key must
be the complete 64-character hexadecimal application ID of an agent and a
value other than @tt{false} permits registration. An empty section rejects all
agents. This ID is a shared bearer credential, not a replacement for HTTPS.
The @tt{[authentication]} section enables browser login when @tt{[users]} has
at least one entry. Each user value is an Argon2id hash, not a plaintext
password. @tt{session-seconds} defaults to seven days and is a sliding idle
timeout. @tt{trusted-proxies} is a semicolon-separated list of IP addresses or
CIDR ranges whose forwarded client address may be trusted; keep it limited to
the actual reverse proxy. The application does not terminate TLS, so use
HTTPS at the reverse proxy before exposing an authenticated instance beyond a
trusted LAN.
Create a password hash with @racket[make-password-hash], or run
@racket[set-user] in the directory containing the INI file. The
@racket[set-user] procedure updates @tt{rkt-web-player.ini} interactively.
@subsection{Playback-agent INI file}
The GUI and CLI agents use a separate private INI file named
@tt{rkt-web-player-agent.ini} in the user's Racket configuration directory.
It contains the following values:
@verbatim{
[server]
url=http://127.0.0.1:8080
[agent]
name=My playback
app-id=64 hexadecimal characters
}
The agent generates @tt{app-id} once and reuses it so the server allowlist
continues to work. The GUI writes the server URL and display name; the CLI can
override them with @tt{--server} and @tt{--name}. Use @tt{--config} with the
CLI to select another agent INI file and therefore another identity. Agents
make only outbound HTTP requests: they register and poll the server, download
assigned tracks, and play them locally. They do not open an inbound port.
@defmodule[rkt-web-player/users] @defmodule[rkt-web-player/users]
@defproc[(make-password-hash [password string?]) string?] { @defproc[(make-password-hash [password string?]) string?] {
@@ -77,6 +305,15 @@ Creates a salted Argon2id password hash suitable for a value in the INI
Checks a password against an encoded Argon2id hash. Checks a password against an encoded Argon2id hash.
} }
@defmodule[rkt-web-player/set-user]
@defproc[(set-user) void?] {
Interactively reads a username and password and writes the corresponding
Argon2id hash to the @tt{[users]} section of @filepath{rkt-web-player.ini} in
the current directory. The password must contain at least twelve characters.
}
@defmodule[rkt-web-player/player-agent] @defmodule[rkt-web-player/player-agent]
@defproc[(run-player-agent) any/c] { @defproc[(run-player-agent) any/c] {
@@ -87,8 +324,10 @@ configured RKT Web Player server, downloads assigned tracks over HTTP, and
plays them with @tt{racket-audio}. Its configured display name is authoritative plays them with @tt{racket-audio}. Its configured display name is authoritative
and is followed by the server. Importing the module does not start the GUI; the and is followed by the server. Importing the module does not start the GUI; the
function must be called explicitly. function must be called explicitly.
The GUI and optional tray support the same ten languages based on the The GUI and its @tt{racket-tray} system tray support the same ten languages
operating-system language, with English as fallback. based on the operating-system language, with English as fallback. Closing or
minimizing the window hides it in the tray. The tray menu restores the window
or shuts down the agent; no SDL3 runtime is required.
} }
@defproc[(run-player-agent-cli [#:server-url server-url @defproc[(run-player-agent-cli [#:server-url server-url
+30 -18
View File
@@ -1,24 +1,36 @@
#lang racket/base #lang racket/base
(require "users.rkt" (require racket/class
simple-ini/class) racket/contract
simple-ini/class
"users.rkt")
(provide set-user) (provide set-user)
(define (set-user) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(displayln "Using rkt-web-player.ini as configuration file") ;; Provided functions
(newline) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(display "Give username: >")
(define user (read-line))
(display "Give password: >")
(define pwd (read-line))
(let ((hash (make-password-hash pwd)))
(define ini (new ini% [file "rkt-web-player.ini"]))
(send ini set! 'users (string->symbol user) hash)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Interactively add or replace one configured web-player user.
; pre : Standard input supplies a username and a password of at least
; twelve characters; rkt-web-player.ini is writable.
; post : The INI file's [users] section contains an Argon2id hash for the
; entered username; the clear-text password is not stored.
; result : Void after the configuration file has been updated.
; internals:
; The small utility uses simple-ini directly and intentionally owns
; no duplicate configuration representation.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (set-user)
(-> void?)
(displayln "Using rkt-web-player.ini as configuration file")
(newline)
(display "Give username: >")
(let ((user (read-line)))
(display "Give password: >")
(let* ((password (read-line))
(hash (make-password-hash password))
(ini (new ini% (file "rkt-web-player.ini"))))
(send ini set! 'users (string->symbol user) hash)
(void))))
-223
View File
@@ -1,223 +0,0 @@
---
name: racket-programmeer-skill
description: Hiermee wordt mijn voorkeur racket programmeerstijl aangegeven.
---
---
name: racket-programmeerstijl
description: Gebruik deze skill wanneer je Racket-code voor Hans schrijft, wijzigt, refactort of beoordeelt. Pas de bestaande, eenvoudige en procedurele programmeerstijl toe; voorkom over-engineering en onnodige abstracties. Gebruik deze skill niet voor algemene uitleg over Racket waarbij geen code voor zijn projecten wordt gemaakt of aangepast.
---
# Racket-programmeerstijl
Gebruik deze stijl wanneer je Racket-code voor Hans schrijft of aanpast.
## Uitgangspunt
Het *allerbelangrijkste* uitgangspunt is dat je de programmerstijl van aangeleverde code volgt.
Als je een zip met een package aangeleverd krijgt via de prompt dan volg je de programmeerstijl die je in de aangeleverde code vindt.
Wanneer bestaande broncode beschikbaar is, heeft de stijl van die broncode voorrang. Sluit daar zo nauw mogelijk op aan.
Schrijf eenvoudige, directe en goed leesbare Racket-code.
Kies de kleinste oplossing die het huidige probleem netjes oplost.
Bouw geen abstraheringslaag voor mogelijk toekomstig gebruik.
En maak geen helpers die alleen maar in de weg staan.
## Structuur
- Houd modules klein en doelgericht.
- Splits functionaliteit alleen af naar een private module wanneer die een duidelijk eigen doel heeft.
- Gebruik voor duidelijke secties bij voorkeur commentaar in deze vorm:
```racket
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
```
of, wanneer dat beter bij de module past:
```racket
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal state / functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
```
Voor publieke functies:
```racket
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
```
- Houd `provide` en `require` eenvoudig en overzichtelijk.
- Voeg geen extra framework, wrapperlaag of generieke infrastructuur toe zonder concrete noodzaak.
## pre/postcondities
Geëxporteerde functies/procedures/classes of functies/procedures/classes die daarvoor duidelijk in
aanmerking komen, d.w.z. die die provided zijn of naar verwachting zullen worden, moeten gedocumenteerd worden.
Zowel in een module scribble als in de code zelf. In het engels.
In de code zelf: minimaal:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : <doel>
; pre : <preconditie(s)>
; post : <postconditie(s)>
; [result:] <resultaat en onder welke conditie>
Over het algemeen wil je de internals van een functie weten. Hoe werkt het en waarom werkt het zo.
; [internals:]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Als een functie/procedure/class overduidelijk in aanmerking komt voor 'provide' en hij staat er nog niet in.
Verzamel dan de lijst en vraag of je ze moet toevoegen.
## Procedures en control flow
- Geef de voorkeur aan gewone procedures met een direct leesbare control flow.
- Gebruik `let`, `if`, `when`, `unless`, `begin` en `cond` expliciet wanneer dat de code duidelijker maakt.
- Maak niet voor iedere kleine stap een aparte helperprocedure.
- Introduceer geen hogere-orde of functionele constructies alleen omdat dat compacter kan.
- Gebruik recursie of een named `let` wanneer dat de meest directe oplossing is.
- Gebruik bij `cond` bij voorkeur deze vorm:
```racket
(cond
([condition] korte body)
([other-condition]
langere body))
(else ... alleen als het nodig is)
```
## Mate van abstractie vs leesbaarheid
Liever concreet dan abstract.
Geef expliciete, goed leesbare constructies de voorkeur boven compacte abstracte idiomen.
Bijvoorbeeld combinaties als (filter values (list (and condition 'symbol) ...)).
Schrijf dan liever expliciet (filter (lambda (x) x) (list (if condition 'symbol #f) ...)).
Vermijd vooral het stapelen van meerdere impliciete idiomen wanneer dat de leesbaarheid vermindert.
## Gebruik lambda.
Geef de voorkeur aan λ boven lambda.
## Waarden en state
- Gebruik `#f` als normale waarde voor "niet gevonden", "niet beschikbaar" of "nog niet geïnitialiseerd" wanneer dat natuurlijk past.
- Expliciete vergelijkingen zoals `(eq? value #f)` zijn prima wanneer dat de bedoeling duidelijk maakt.
- Houd state eenvoudig. Een gewone modulevariabele zoals `cached-git-exe` is prima wanneer daarvoor geen zwaarder mechanisme nodig is.
- Gebruik geen parameters, structs, classes of objectlagen wanneer een gewone variabele of procedure voldoende is.
## Publieke API
- Gebruik `define/contract` voor publieke procedures wanneer een contract nuttige documentatie en controle geeft.
- Houd publieke procedures klein en voorspelbaar.
- Verander een bestaande publieke API niet zonder noodzaak.
- Voeg geen extra publieke functies toe voor hypothetische toekomstige behoeften.
## Fouten en interactie
- Geef duidelijke en concrete foutmeldingen.
- Los eenvoudige interactieve invoer lokaal en procedureel op.
- Maak foutafhandeling niet generieker dan nodig.
- Als een externe executable of voorziening ontbreekt, meld precies wat ontbreekt en wat de gebruiker kan doen.
## Configuratie
- Bewaar lokale configuratie in een kleine, afzonderlijke private module wanneer dat de hoofdmodule eenvoudiger maakt.
- Gebruik bestaande projectvoorzieningen, zoals `simple-ini`, rechtstreeks in plaats van er een extra abstractielaag omheen te bouwen.
- Dupliceer geen configuratie die al door een extern programma zelf wordt beheerd.
## Naamgeving en leesbaarheid
- Kies concrete, korte namen die passen bij de bestaande code.
- Gebruik Engels voor identifiers en technische namen wanneer de bestaande code dat doet.
- Schrijf comments alleen wanneer ze iets toevoegen dat niet al vanzelf uit de code blijkt.
- Geef de voorkeur aan een paar duidelijke regels boven een compacte maar moeilijker leesbare expressie.
## Vermijd
Vermijd zonder concrete noodzaak:
- over-engineering;
- generieke wrappers;
- extra abstraheringslagen;
- dynamische `require`-constructies;
- classes wanneer procedures volstaan;
- structs wanneer een eenvoudige waarde volstaat;
- configuratie-objecten of dependency-injectionpatronen;
- veel kleine helperprocedures die de control flow versnipperen;
- refactors die alleen bedoeld zijn om code "slimmer" of abstracter te maken.
## Werkwijze bij aanpassen van bestaande code
1. Lees eerst de omliggende module(s).
2. Neem naamgeving, inspringing, control-flow-stijl en module-indeling over.
3. Wijzig alleen wat voor de gevraagde stap nodig is.
4. Houd bestaande werkende code intact als er geen reden is die te veranderen.
5. Voeg geen volgende architectuurstappen alvast toe.
6. Controleer of de oplossing eenvoudiger is dan het probleem; zo niet, vereenvoudig.
## Referentiestijl
Deze vorm is representatief:
```racket
(define cached-value #f)
(define/contract (get-value)
(-> (or/c path? #f))
(if (eq? cached-value #f)
(let ((value (find-value)))
(set! cached-value value)
value)
cached-value))
```
Een wat langere maar direct leesbare implementatie heeft de voorkeur boven een kortere oplossing met meerdere nieuwe abstracties.
# Schrijven van testgevallen voor modules/packages
Een test die alleen werkt vanuit de development directory, op het development-OS of met de lokale shell/environment is geen geldige package-test.
## Racket Package Index / build-service tests
Behandel de Racket Package Index/build service als een aparte, strikte
en onbekende testomgeving.
Bij packagecode en tests gelden daarom altijd de volgende regels:
- Maak nooit aannames over `current-directory` of de directory van waaruit
code of tests worden uitgevoerd. Bepaal testdata en paden expliciet en
relocatable, bijvoorbeeld met runtime paths en tijdelijke directories.
- Maak nooit impliciete aannames over het besturingssysteem. Vermijd
OS-specifieke paden, shells, executables en gedrag, of handel verschillen
expliciet per platform af.
- Maak tests onafhankelijk van lokale environment state. Benodigde
environment variables moeten expliciet en bij voorkeur geïsoleerd worden
ingesteld.
- Een succesvolle test moet stil en ondubbelzinnig succesvol zijn.
Laat geen verwachte foutmeldingen naar de echte stdout/stderr lekken,
omdat `raco test --drdr` en de Package Index dergelijke output als een
mogelijke test failure kunnen classificeren.
- Verwachte foutoutput moet worden gecaptureerd en geassert.
- Tests moeten hun eigen tijdelijke state en testbestanden aanmaken en
mogen geen bestanden, processen, environment changes of andere state
achterlaten.
- Test packagewijzigingen waar mogelijk ook in een omgeving die lijkt op:
`raco setup --check-pkg-deps` en
`raco test --drdr --package <package>`.
+87
View File
@@ -0,0 +1,87 @@
import assert from "node:assert/strict";
import { test } from "node:test";
import { PlayerStateClient } from "../public/player-state.js";
test("polls reuse tracks and accept edits from another browser", async () => {
const tracks = [{ title: "First" }];
const changedTracks = [{ title: "Second" }];
const responses = [
{ playlistVersion: "first", tracks, position: 0 },
{ playlistVersion: "first", tracks: null, position: 1 },
{ playlistVersion: "changed", tracks: changedTracks, position: 2 },
{ playlistVersion: "changed", tracks: null, position: 3 },
];
const paths = [];
const client = new PlayerStateClient(async (path) => {
paths.push(path);
return responses.shift();
});
assert.equal((await client.request("/api/state")).tracks, tracks);
const unchanged = await client.request("/api/state");
assert.equal(unchanged.tracks, tracks);
assert.equal(unchanged.position, 1);
assert.equal((await client.request("/api/state")).tracks, changedTracks);
assert.equal((await client.request("/api/state")).tracks, changedTracks);
assert.deepEqual(paths, [
"/api/state", "/api/state?playlistVersion=first",
"/api/state?playlistVersion=first", "/api/state?playlistVersion=changed",
]);
});
test("commands and discovery wait for polling and use its latest version", async () => {
let finishPoll;
const paths = [];
const commandBody = { index: 1 };
const client = new PlayerStateClient((path, body) => {
paths.push(path);
if (paths.length === 1) {
return new Promise((resolve) => { finishPoll = resolve; });
}
if (paths.length === 2) {
assert.equal(body, commandBody);
return { playlistVersion: "other-tab", tracks: [] };
}
return { playlistVersion: "other-tab", tracks: null };
});
const poll = client.request("/api/state");
const command = client.request("/api/command/tab-select", commandBody);
const discovery = client.request("/api/discover", {});
await Promise.resolve();
assert.deepEqual(paths, ["/api/state"]);
finishPoll({ playlistVersion: "original-tab", tracks: [{ title: "First" }] });
await poll;
assert.deepEqual((await command).tracks, []);
assert.deepEqual((await discovery).tracks, []);
assert.deepEqual(paths, [
"/api/state",
"/api/command/tab-select?playlistVersion=original-tab",
"/api/discover?playlistVersion=other-tab",
]);
});
test("a failed request leaves the queue usable", async () => {
let calls = 0;
const client = new PlayerStateClient(async () => {
if (++calls === 1) throw new Error("Offline");
return { playlistVersion: "recovered", tracks: [] };
});
await assert.rejects(client.request("/api/state"), /Offline/);
assert.deepEqual((await client.request("/api/state")).tracks, []);
});
test("mismatched omitted tracks force a full refresh instead of stale reuse", async () => {
const paths = [];
const responses = [
{ playlistVersion: "before", tracks: [{ title: "Before" }] },
{ playlistVersion: "after", tracks: null },
{ playlistVersion: "after", tracks: [] },
];
const client = new PlayerStateClient(async (path) => {
paths.push(path);
return responses.shift();
});
await client.request("/api/state");
await assert.rejects(client.request("/api/state"), /Playlist cache/);
assert.deepEqual((await client.request("/api/state")).tracks, []);
assert.equal(paths[2], "/api/state");
});
+96
View File
@@ -0,0 +1,96 @@
import assert from "node:assert/strict";
import { test } from "node:test";
import { PlaylistLibrary } from "../public/playlist-library.js";
// Minimal DOM elements let the view's actions run without a browser dependency.
class Element {
constructor() {
this.children = [];
this.dataset = {};
this.attributes = {};
this.listeners = {};
this.classes = new Set();
this.classList = { toggle: (name, active) => active ? this.classes.add(name) : this.classes.delete(name) };
}
append(...children) { this.children.push(...children); }
replaceChildren(...children) { this.children = children; }
setAttribute(name, value) { this.attributes[name] = value; }
addEventListener(name, callback) { this.listeners[name] = callback; }
fire(name, values = {}) { this.listeners[name]({ target: this, stopPropagation() {}, preventDefault() {}, ...values }); }
focus() {}
closest() { return null; }
}
class Fixture {
constructor() {
this.nodes = new Map();
this.commands = [];
this.language = "en";
globalThis.window = { RktTranslate: {
language: () => this.language,
t: (key, values = {}) => `${key} ${values.name || ""}`,
} };
globalThis.document = { createElement: () => new Element() };
this.view = new PlaylistLibrary({ querySelector: (selector) => this.node(selector) },
(name, data) => this.commands.push({ name, data }), duration => `${duration} seconds`);
}
node(selector) {
if (!this.nodes.has(selector)) this.nodes.set(selector, new Element());
return this.nodes.get(selector);
}
}
test("library tabs change only the visible panel", () => {
const fixture = new Fixture();
fixture.node("#saved-playlists-tab").fire("click");
assert.equal(fixture.node("#folders-panel").hidden, true);
assert.equal(fixture.node("#saved-playlists-panel").hidden, false);
assert.equal(fixture.node("#saved-playlists-tab").attributes["aria-selected"], "true");
fixture.node("#saved-playlists-tab").fire("keydown", { key: "ArrowLeft" });
assert.equal(fixture.node("#folders-panel").hidden, false);
assert.deepEqual(fixture.commands, []);
});
test("plus and play address the saved playlist UUID and never use item-add/play", () => {
const fixture = new Fixture();
fixture.view.render([{ id: "saved-id", name: "Music", count: 2, duration: 120 }]);
const row = fixture.node("#saved-playlists").children[0];
row.fire("click");
assert.deepEqual(fixture.commands, []);
assert.ok(row.classes.has("selected"));
row.children[2].children[1].fire("click");
row.children[2].children[0].fire("click");
assert.deepEqual(fixture.commands, [
{ name: "playlist-open", data: { id: "saved-id" } },
{ name: "playlist-play", data: { id: "saved-id" } },
]);
assert.equal(fixture.node("#saved-playlists-empty").hidden, true);
});
test("unchanged summaries reuse rows while metadata and language changes refresh them", () => {
const fixture = new Fixture();
const playlists = [{ id: "one", name: "Music", count: 0, duration: 0 }];
fixture.view.render(playlists);
const row = fixture.node("#saved-playlists").children[0];
assert.equal(row.children[2].children[0].disabled, true);
assert.equal(row.children[2].children[1].disabled, false);
fixture.view.render(playlists);
assert.equal(fixture.node("#saved-playlists").children[0], row);
fixture.language = "nl";
fixture.view.render(playlists);
assert.notEqual(fixture.node("#saved-playlists").children[0], row);
fixture.view.render([{ ...playlists[0], name: "Renamed" }]);
assert.equal(fixture.node("#saved-playlists").children[0].children[1].textContent, "Renamed");
fixture.view.render([]);
assert.equal(fixture.node("#saved-playlists-empty").hidden, false);
});
test("keyboard opening does not intercept a nested action button", () => {
const fixture = new Fixture();
fixture.view.render([{ id: "one", name: "Music", count: 1, duration: 60 }]);
const row = fixture.node("#saved-playlists").children[0];
row.fire("keydown", { key: "Enter", target: row.children[2].children[0] });
assert.deepEqual(fixture.commands, []);
row.fire("keydown", { key: "Enter" });
assert.deepEqual(fixture.commands, [{ name: "playlist-open", data: { id: "one" } }]);
});