diff --git a/.gitignore b/.gitignore index a9e5940..746f237 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,4 @@ rkt-web-player.ini # Runtime playlist keystore data/*.keystore* +/.scribble-build diff --git a/ARCHITECTURE.md b/ARCHITECTURE.md index 5447702..725bf7b 100644 --- a/ARCHITECTURE.md +++ b/ARCHITECTURE.md @@ -386,9 +386,10 @@ random application ID therefore acts as a shared bearer credential, but must 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 -configuration and state to widgets. Optional tray integration is loaded -dynamically through SDL3, so CLI use and the default GUI installation do not -acquire a mandatory SDL dependency. +configuration and state to widgets. It uses `racket-tray` directly for its +native tray icon, symbolic Open/Exit menu and portable hide-on-minimize +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 operate on opaque indexes instead of sending paths directly. The DLNA backend diff --git a/README.md b/README.md index 9e25945..3cb2765 100644 --- a/README.md +++ b/README.md @@ -193,22 +193,20 @@ opgeruimd zodra ze niet meer nodig zijn en bij afsluiten van de agent. ### Systeemvak -De GUI gebruikt optioneel de open-source SDL3-tray-API. Als zowel het Racket- -pakket `sdl3` als de native SDL3-, SDL3_image- en SDL3_ttf-libraries aanwezig -zijn, sluit de vensterknop de agent naar het systeemvak. Het menu bevat -**RKT Web Player Agent openen** en **Afsluiten**. Zonder SDL3 blijft de agent -gewoon werken en sluit de vensterknop het proces af. Er wordt geen PowerShell- -proces of externe tray-helper gestart. +De GUI gebruikt het Racket-pakket `racket-tray`. Minimaliseren en de +vensterknop verbergen de agent in het systeemvak. Het menu bevat +**RKT Web Player Agent openen** en **Afsluiten**; openen herstelt ook een +geminimaliseerd venster. De tray is onderdeel van de normale package- +dependencies en vereist geen SDL3-pakket of SDL3-libraries meer. + +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 -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 De headless agent gebruikt exact dezelfde polling-, download-, audio- en diff --git a/info.rkt b/info.rkt index 88dfc10..c8acfbe 100644 --- a/info.rkt +++ b/info.rkt @@ -18,6 +18,7 @@ "racket-audio-dlna" "racket-mimetypes" "racket-sonos" + "racket-tray" "racket-upnp" "simple-ini" "simple-log" diff --git a/main.rkt b/main.rkt index bebb111..3e66245 100644 --- a/main.rkt +++ b/main.rkt @@ -36,7 +36,7 @@ (define (configuration-list value defaults) (cond - ((list? value) (map (lambda (item) (format "~a" item)) value)) + ((list? value) (map (λ (item) (format "~a" item)) value)) ((and (string? value) (not (string=? (string-trim value) ""))) (map string-trim (string-split value ";"))) diff --git a/player-agent-cli.rkt b/player-agent-cli.rkt index bf913be..d9639f2 100644 --- a/player-agent-cli.rkt +++ b/player-agent-cli.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/cmdline + racket/contract racket/format racket/string simple-log @@ -9,87 +10,120 @@ (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) (cond ((not track) "geen track") (else - (define title (hash-ref track 'title #f)) - (define artist (hash-ref track 'artist #f)) - (define filename (hash-ref track 'filename "onbekend")) - (cond - ((and artist title (not (string=? artist ""))) - (format "~a — ~a" artist title)) - (title title) - (else filename))))) + (let ((title (hash-ref track 'title #f)) + (artist (hash-ref track 'artist #f)) + (filename (hash-ref track 'filename "onbekend"))) + (cond + ((and artist title (not (string=? artist ""))) + (format "~a — ~a" artist title)) + (title title) + (else filename)))))) -(define (run-player-agent-cli #:server-url [server-override #f] - #:name [name-override #f] - #:config-file [config-file #f]) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Provided functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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) - (define loaded - (if config-file - (load-player-agent-config config-file) - (load-player-agent-config))) - (define server-url - (string-trim (or server-override - (player-agent-config-server-url loaded)))) - (define name - (string-trim (or name-override - (player-agent-config-name loaded)))) - (define config - (struct-copy player-agent-config loaded - (server-url server-url) - (name name))) - (save-player-agent-config! config) - - (define (write-status message) - (printf "[agent] ~a~n" message) - (flush-output)) - - (define runtime - (make-player-agent-runtime - server-url - name - (player-agent-config-app-id config) - #:status-callback write-status - #:denied-callback - (lambda (message) - (eprintf "~a~n" message) - (flush-output (current-error-port))))) - - (printf "RKT Web Player CLI Agent~n") - (printf "Naam: ~a~n" name) - (printf "Server: ~a~n" server-url) - (printf "Applicatie-ID: ~a~n" (player-agent-config-app-id config)) - (printf "Stoppen: Ctrl+C~n") - (flush-output) - - (define monitor #f) - (dynamic-wind - (lambda () - ((player-agent-runtime-start! runtime)) - (set! monitor - (thread - (lambda () - (let loop ((previous #f)) - (define snapshot - ((player-agent-runtime-snapshot runtime))) - (define summary - (cons (hash-ref snapshot 'state "stopped") - (track-description - ((player-agent-runtime-current-track runtime))))) - (unless (equal? summary previous) - (printf "[playback] ~a — ~a~n" (car summary) (cdr summary)) - (flush-output)) - (sleep 1) - (loop summary)))))) - (lambda () - (with-handlers ((exn:break? void)) - (sync never-evt))) - (lambda () - (when (and monitor (not (thread-dead? monitor))) - (kill-thread monitor)) - ((player-agent-runtime-shutdown! runtime))))) + (let* ((loaded + (if config-file + (load-player-agent-config config-file) + (load-player-agent-config))) + (server-url + (string-trim (or server-override + (player-agent-config-server-url loaded)))) + (name + (string-trim (or name-override + (player-agent-config-name loaded)))) + (config + (struct-copy player-agent-config loaded + (server-url server-url) + (name name))) + (write-status + (λ (message) + (printf "[agent] ~a~n" message) + (flush-output))) + (runtime + (make-player-agent-runtime + server-url + name + (player-agent-config-app-id config) + #:status-callback write-status + #:denied-callback + (λ (message) + (eprintf "~a~n" message) + (flush-output (current-error-port))))) + (monitor #f)) + (save-player-agent-config! config) + (printf "RKT Web Player CLI Agent~n") + (printf "Naam: ~a~n" name) + (printf "Server: ~a~n" server-url) + (printf "Applicatie-ID: ~a~n" (player-agent-config-app-id config)) + (printf "Stoppen: Ctrl+C~n") + (flush-output) + (dynamic-wind + (λ () + ((player-agent-runtime-start! runtime)) + (set! monitor + (thread + (λ () + (let loop ((previous #f)) + (let* ((snapshot + ((player-agent-runtime-snapshot runtime))) + (summary + (cons + (hash-ref snapshot 'state "stopped") + (track-description + ((player-agent-runtime-current-track runtime)))))) + (unless (equal? summary previous) + (printf "[playback] ~a — ~a~n" + (car summary) + (cdr summary)) + (flush-output)) + (sleep 1) + (loop summary))))))) + (λ () + (with-handlers ((exn:break? void)) + (sync never-evt))) + (λ () + (when (and monitor (not (thread-dead? monitor))) + (kill-thread monitor)) + ((player-agent-runtime-shutdown! runtime)))))) (module+ main (define server-url #f) diff --git a/player-agent.rkt b/player-agent.rkt index 4d15d51..8f466cb 100644 --- a/player-agent.rkt +++ b/player-agent.rkt @@ -1,5 +1,8 @@ #lang racket/base +(require racket/class + racket/contract) + (provide run-player-agent run-player-agent-cli) @@ -8,8 +11,12 @@ ; pre : A graphical desktop is available. ; post : The agent remains active until its window is closed. ; 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) + (-> object?) ((dynamic-require "private/player-agent-gui.rkt" 'run-player-agent-gui))) @@ -18,10 +25,18 @@ ; pre : The configured server is reachable. ; post : The agent remains active until interrupted. ; 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] - #:name [name #f] - #:config-file [config-file #f]) +(define/contract (run-player-agent-cli #:server-url [server-url #f] + #:name [name #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) #:server-url server-url #:name name diff --git a/private/dlna-playback.rkt b/private/dlna-playback.rkt index 77cd5a8..956c2b8 100644 --- a/private/dlna-playback.rkt +++ b/private/dlna-playback.rkt @@ -77,7 +77,7 @@ (list-ref (current-tracks playback) index))) (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)))) (define (same-file? first second) @@ -136,7 +136,7 @@ ((not (equal? following (dlna-playback-prepared-index playback))) (with-handlers ((exn:fail? - (lambda (exception) + (λ (exception) (set-dlna-playback-prepared-index! playback #f) (warn-web-player-dlna "Could not prepare next DLNA track: ~a" @@ -155,7 +155,7 @@ "index" index)) (with-handlers ((exn:fail? - (lambda (exception) + (λ (exception) (report-failure! playback (exn-message exception)) (raise exception)))) (dlna-player-play! (dlna-playback-player playback) (track-file item)) @@ -286,11 +286,11 @@ (when (dlna-playback-running? playback) (with-handlers ((exn:fail? - (lambda (exception) + (λ (exception) (warn-web-player-dlna "Could not update DLNA playback state: ~a" (exn-message exception))))) - (with-lock playback (lambda () (poll/locked! playback)))) + (with-lock playback (λ () (poll/locked! playback)))) (loop))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -319,26 +319,26 @@ playback) (define (dlna-playback-play-index! playback index) - (with-lock playback (lambda () (play-index/locked! playback index)))) + (with-lock playback (λ () (play-index/locked! playback index)))) (define (dlna-playback-pause! playback) (with-lock playback - (lambda () + (λ () (dlna-player-pause! (dlna-playback-player playback)) (notify! playback 'paused (dlna-player-info (dlna-playback-player playback)))))) (define (dlna-playback-resume! playback) (with-lock playback - (lambda () + (λ () (dlna-player-resume! (dlna-playback-player playback)) (notify! playback 'playing (dlna-player-info (dlna-playback-player playback)))))) (define (dlna-playback-stop! playback) (with-lock playback - (lambda () + (λ () (set-dlna-playback-stop-requested?! playback #t) (set-dlna-playback-playing-seen?! playback #f) (set-dlna-playback-progress-seen?! playback #f) @@ -351,7 +351,7 @@ (define (dlna-playback-seek-percentage! playback percentage) (with-lock playback - (lambda () + (λ () (dlna-player-seek-percentage! (dlna-playback-player playback) percentage) ;; racket-audio-dlna updates its cache synchronously after Seek. Publish ;; that value immediately so the web slider does not jump back. @@ -363,7 +363,7 @@ (define (dlna-playback-volume! playback percentage) (with-lock playback - (lambda () + (λ () (dlna-player-volume! (dlna-playback-player playback) percentage) (define info (dlna-player-info (dlna-playback-player playback))) (notify! playback @@ -373,7 +373,7 @@ (define (dlna-playback-repeat! playback repeat) (with-lock playback - (lambda () + (λ () (set-dlna-playback-repeat! playback repeat) (set-dlna-playback-prepared-index! playback #f) (prepare-next! playback)))) @@ -387,7 +387,7 @@ (set-dlna-playback-monitor! playback #f) (with-lock playback - (lambda () + (λ () (dlna-player-close! (dlna-playback-player playback)))))) (module+ test @@ -400,7 +400,7 @@ (track (build-path "music" "02.flac") "Second" "Artist" "Album" 60 "audio/flac")) (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 (make-semaphore 1))) diff --git a/private/library.rkt b/private/library.rkt index 35b683d..c1bf338 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -139,12 +139,12 @@ (file-exists? file) (audio-file? file) (let ((full-file - (with-handlers ((exn:fail? (lambda (_) #f))) + (with-handlers ((exn:fail? (λ (_) #f))) (simplify-path (path->complete-path file) #t)))) (and full-file (for/or ((library (in-list libraries))) (define root - (with-handlers ((exn:fail? (lambda (_) #f))) + (with-handlers ((exn:fail? (λ (_) #f))) (simplify-path (path->complete-path (music-library-root library)) #t))) @@ -185,7 +185,7 @@ (list name (normal-case-path (path->complete-path path))))) - (lambda (first second) + (λ (first second) (equal? (cadr first) (cadr second)))))) (for/list ((named-root (in-list roots)) (index (in-naturals))) diff --git a/private/player-agent-config.rkt b/private/player-agent-config.rkt index 871a45f..0624a74 100644 --- a/private/player-agent-config.rkt +++ b/private/player-agent-config.rkt @@ -1,6 +1,7 @@ #lang racket/base (require file/sha1 + racket/contract racket/os racket/path racket/random @@ -14,35 +15,75 @@ (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))) -(define (valid-app-id? value) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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))) + (regexp-match? #px"^[0-9a-fA-F]{64}$" value) + #t)) -(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) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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)) -(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)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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))) (module+ test (require rackunit @@ -52,18 +93,18 @@ (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)))) + (λ () + (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)))) diff --git a/private/player-agent-core.rkt b/private/player-agent-core.rkt index 8edabcd..df96f74 100644 --- a/private/player-agent-core.rkt +++ b/private/player-agent-core.rkt @@ -3,6 +3,7 @@ (require json net/url racket-audio + racket/contract racket/file racket/path racket/port @@ -17,6 +18,15 @@ (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: +; Procedures keep the mutable audio and polling state private without +; introducing a class or a second generic backend abstraction. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (struct player-agent-runtime (start! reconnect! shutdown! snapshot current-track running? app-id) #:transparent) @@ -29,26 +39,27 @@ (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)))) + (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))))) (define (normal-state state) (cond @@ -59,49 +70,69 @@ (define (safe-delete-file file) (when (and file (file-exists? file)) (with-handlers ((exn:fail? - (lambda (exception) + (λ (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)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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: +; One closure owns the simple mutable state shared by polling, +; command and audio callbacks. Keeping these procedures together +; makes their synchronization and cleanup order directly visible. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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))) (define (with-agent-state proc) (call-with-semaphore state-lock proc)) @@ -110,98 +141,98 @@ (if (eq? value #f) fallback value)) (define (snapshot) - (with-agent-state (lambda () agent-state))) + (with-agent-state (λ () agent-state))) (define (current-track) - (with-agent-state (lambda () current-track-value))) + (with-agent-state (λ () 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)))))) + (λ () + (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))))))) (define (ensure-audio!) (unless audio (set! audio (make-audio-player - (lambda (_handle state full-state) + (λ (_handle state full-state) (update-from-audio! state full-state)) - (lambda (handle) + (λ (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))) + (let ((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)) + (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))) (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))) + (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)))) (define (discard-unused-media! keep-key) (for ((entry (in-list (hash->list cached-media)))) @@ -212,130 +243,134 @@ ;; 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)) + (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 - (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) + (λ () + (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 () - (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))))))) + (λ () (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? + (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")) + (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 () - (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)) + (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 - (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)))) + (λ () + (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)))) + (λ (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? - (lambda (exception) + (λ (exception) (warn-player-agent "Connection cycle failed: ~a" (exn-message exception)) (set-agent-error! (exn-message exception)) @@ -352,34 +387,35 @@ (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))))) + (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))))) @@ -421,5 +457,5 @@ shutdown! snapshot current-track - (lambda () running) - app-id)) + (λ () running) + app-id))) diff --git a/private/player-agent-gui.rkt b/private/player-agent-gui.rkt index 17555f0..fb64f14 100644 --- a/private/player-agent-gui.rkt +++ b/private/player-agent-gui.rkt @@ -1,15 +1,16 @@ #lang racket/base (require racket/class + racket/contract racket/format racket/gui/base racket/os - racket/path + racket/runtime-path racket/string + racket-tray simple-log "player-agent-config.rkt" "player-agent-core.rkt" - "player-agent-tray.rkt" "translate.rkt") (provide run-player-agent-gui) @@ -20,256 +21,393 @@ (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) - (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) + (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) - (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"))) + (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")))) -(define (run-player-agent-gui) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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)) - (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) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; 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)) - (define (show-status! message) - (queue-callback - (lambda () - (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)) - (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!)) - (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 + "—"))))) - (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 - "—")))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; 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)))) - (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))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; 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)))) - (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)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; 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)) - (define (quit!) - (queue-callback - (lambda () - (shutdown!) - (when frame (send frame show #f))) - #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))) - (define agent-frame% - (class frame% - (super-new) - (define/augment (on-close) - (if tray - (send this show #f) - (begin - (shutdown!) - (inner (void) on-close)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; 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!)))) - (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) + (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)) - (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))) + (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)))) - (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 + (set! playback-timer (new timer% - (notify-callback (tray-controller-update! tray)) - (interval 100)))) + (notify-callback refresh-playback-status!) + (interval 500))) + (refresh-playback-status!) - (send frame show #t) - ((player-agent-runtime-start! runtime)) - (send connect-button set-label (tr 'reconnect)) - frame) + (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)) + +(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))) diff --git a/private/player-agent-tray.rkt b/private/player-agent-tray.rkt deleted file mode 100644 index 62afd84..0000000 --- a/private/player-agent-tray.rkt +++ /dev/null @@ -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!))))) diff --git a/private/player.rkt b/private/player.rkt index 2f6abc7..dcb563c 100644 --- a/private/player.rkt +++ b/private/player.rkt @@ -278,7 +278,7 @@ (hash-ref! (player-playlist-contexts value) normalized - (lambda () (new-playlist-context value normalized)))) + (λ () (new-playlist-context value normalized)))) (define (context-tracks context) (playlist-tab-tracks @@ -324,7 +324,7 @@ (define context (playlist-context-for! value normalized)) (with-state-lock value - (lambda () + (λ () (set-player-tabs! value (playlist-context-tabs context)) (set-player-current-tab-index! value @@ -1649,7 +1649,7 @@ (define item (call-with-semaphore (player-command-lock value) - (lambda () + (λ () (define context (playlist-context-for! value @@ -1659,7 +1659,7 @@ (player-tracks value) (append-map playlist-tab-tracks (playlist-context-tabs context)))) - (findf (lambda (candidate) + (findf (λ (candidate) (string=? (track-cache-key candidate) artwork-id)) candidates)))) (and item (track-artwork item))) diff --git a/private/playlists.rkt b/private/playlists.rkt index c0c4e95..72ceba6 100644 --- a/private/playlists.rkt +++ b/private/playlists.rkt @@ -69,7 +69,7 @@ id name (filter-map - (lambda (item) (datum->track item libraries)) + (λ (item) (datum->track item libraries)) tracks)))))) (define (open-playlist-store file) @@ -82,7 +82,7 @@ (when store (call-with-semaphore (playlist-store-lock store) - (lambda () (ks-close (playlist-store-keystore store))))) + (λ () (ks-close (playlist-store-keystore store))))) (void)) (define (load-user-playlists store username libraries) @@ -90,12 +90,12 @@ '() (call-with-semaphore (playlist-store-lock store) - (lambda () + (λ () (define ks (playlist-store-keystore store)) (define ids (ks-get ks (user-playlists-key username) '())) (if (list? ids) (filter-map - (lambda (id) + (λ (id) (datum->tab id (ks-get ks id #f) libraries)) (remove-duplicates (filter uuid-string? ids) string=?)) '()))))) @@ -104,7 +104,7 @@ (when store (call-with-semaphore (playlist-store-lock store) - (lambda () + (λ () (define ks (playlist-store-keystore store)) (define index-key (user-playlists-key username)) (define old-ids (ks-get ks index-key '())) @@ -174,13 +174,13 @@ (define outside (build-path root "outside.flac")) (define store-file (build-path root "data" "playlists.keystore")) (dynamic-wind - (lambda () + (λ () (make-directory music) (make-directory music-two) (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 outside void)) - (lambda () + (λ () (define libraries (make-music-libraries (list music music-two))) (define store (open-playlist-store store-file)) (define first-id (uuid-string)) @@ -253,4 +253,4 @@ (car (load-user-playlists store "unsafe" libraries))) '()) (close-playlist-store! store)) - (lambda () (delete-directory/files root)))) + (λ () (delete-directory/files root)))) diff --git a/private/users.rkt b/private/users.rkt index 14ea18b..36c374b 100644 --- a/private/users.rkt +++ b/private/users.rkt @@ -3,6 +3,7 @@ (require crypto crypto/argon2 net/private/ip + racket/contract racket/list racket/random racket/string @@ -58,7 +59,8 @@ ; post : No module state is changed. ; result : A salted Argon2id hash encoded as a string. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (make-password-hash password) +(define/contract (make-password-hash password) + (-> string? string?) (unless (and (string? password) (>= (string-length password) 12)) (raise-argument-error @@ -75,10 +77,11 @@ ; post : No module state is changed. ; result : #t only when both values are strings and the password matches. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (password-hash-valid? password encoded) +(define/contract (password-hash-valid? password encoded) + (-> any/c any/c boolean?) (and (string? password) (string? encoded) - (with-handlers ((exn:fail? (lambda (_) #f))) + (with-handlers ((exn:fail? (λ (_) #f))) (pwhash-verify password-kdf (string->bytes/utf-8 password) encoded)))) @@ -101,7 +104,7 @@ (raise-argument-error 'make-auth-manager "IP address or CIDR network" value)) (define address (with-handlers ((exn:fail? - (lambda (_) + (λ (_) (raise-argument-error 'make-auth-manager "IP address or CIDR network" @@ -118,7 +121,7 @@ (ip-network address prefix)) (define (network-contains? network address-string) - (with-handlers ((exn:fail? (lambda (_) #f))) + (with-handlers ((exn:fail? (λ (_) #f))) (define candidate (normal-ip-bytes address-string)) (define expected (ip-network-address network)) (and (= (bytes-length candidate) (bytes-length expected)) @@ -140,7 +143,7 @@ (bytes->string/utf-8 (header-value value))))) (define (trusted-proxy? manager address) - (ormap (lambda (network) (network-contains? network address)) + (ormap (λ (network) (network-contains? network address)) (auth-manager-trusted-proxies manager))) (define (request-address manager request) @@ -160,7 +163,8 @@ ; post : Manager remains unchanged. ; 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)))) (define (request-session-token request) @@ -183,7 +187,8 @@ ; result : "anonymous" when authentication is disabled, the normalized ; username for a valid session, or #f when login is required. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (auth-request-user manager request) +(define/contract (auth-request-user manager request) + (-> auth-manager? request? (or/c #f string?)) (cond ((not (auth-enabled? manager)) "anonymous") (else @@ -192,7 +197,7 @@ (and token (call-with-semaphore (auth-manager-lock manager) - (lambda () + (λ () (prune-sessions! manager now) (let ((value (hash-ref (auth-manager-sessions manager) token @@ -230,34 +235,39 @@ ; internals: Unknown users follow the same Argon2id verification path as known ; users to reduce username-dependent timing differences. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (auth-login! manager request username password) - (define address (request-address manager request)) - (define now (current-seconds)) - (define normalized (string-downcase (string-trim username))) - (call-with-semaphore - (auth-manager-lock manager) - (lambda () - (if (failure-blocked? manager address now) - 'rate-limited - (let* ((stored (hash-ref (auth-manager-users manager) - normalized - #f)) - (valid? - (password-hash-valid? - password - (or stored dummy-password-hash)))) - (if (and stored valid?) - (let ((token - (bytes->hex-string (crypto-random-bytes 32)))) - (hash-remove! (auth-manager-failed manager) address) - (prune-sessions! manager now) - (hash-set! (auth-manager-sessions manager) - token - (session normalized now now)) - token) - (begin - (record-failure! manager address now) - #f))))))) +(define/contract (auth-login! manager request username password) + (-> auth-manager? + request? + string? + string? + (or/c #f 'rate-limited string?)) + (let ((address (request-address manager request)) + (now (current-seconds)) + (normalized (string-downcase (string-trim username)))) + (call-with-semaphore + (auth-manager-lock manager) + (λ () + (if (failure-blocked? manager address now) + 'rate-limited + (let* ((stored (hash-ref (auth-manager-users manager) + normalized + #f)) + (valid? + (password-hash-valid? + password + (or stored dummy-password-hash)))) + (if (and stored valid?) + (let ((token + (bytes->hex-string (crypto-random-bytes 32)))) + (hash-remove! (auth-manager-failed manager) address) + (prune-sessions! manager now) + (hash-set! (auth-manager-sessions manager) + token + (session normalized now now)) + token) + (begin + (record-failure! manager address now) + #f)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : End the browser session named by the request cookie. @@ -265,12 +275,13 @@ ; post : The matching server-side session is removed when it exists. ; result : Void. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (auth-logout! manager request) +(define/contract (auth-logout! manager request) + (-> auth-manager? request? void?) (let ((token (request-session-token request))) (when token (call-with-semaphore (auth-manager-lock manager) - (lambda () + (λ () (hash-remove! (auth-manager-sessions manager) token)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -280,7 +291,8 @@ ; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value whose Max-Age ; equals the configured session lifetime. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (auth-session-cookie manager token) +(define/contract (auth-session-cookie manager token) + (-> auth-manager? string? bytes?) (string->bytes/utf-8 (format "~a=~a; Path=/; Max-Age=~a; Secure; HttpOnly; SameSite=Strict" @@ -299,7 +311,8 @@ ; this half-life threshold prevents the one-second player poll from ; returning Set-Cookie every second. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (auth-renewal-cookie manager request) +(define/contract (auth-renewal-cookie manager request) + (-> auth-manager? request? (or/c #f bytes?)) (and (auth-enabled? manager) (let ((token (request-session-token request)) (now (current-seconds))) @@ -308,17 +321,17 @@ (auth-manager-lock manager) (λ () (prune-sessions! manager now) - (define value - (hash-ref (auth-manager-sessions manager) token #f)) - (and value - (>= (- now (session-last-cookie-renewal value)) - (max 1 - (quotient - (auth-manager-session-seconds manager) - 2))) - (begin - (set-session-last-cookie-renewal! value now) - (auth-session-cookie manager token))))))))) + (let ((value + (hash-ref (auth-manager-sessions manager) token #f))) + (and value + (>= (- now (session-last-cookie-renewal value)) + (max 1 + (quotient + (auth-manager-session-seconds manager) + 2))) + (begin + (set-session-last-cookie-renewal! value now) + (auth-session-cookie manager token)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Encode deletion of the browser session cookie. @@ -326,7 +339,8 @@ ; post : No module state is changed. ; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value with Max-Age 0. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (auth-expired-cookie) +(define/contract (auth-expired-cookie) + (-> bytes?) (string->bytes/utf-8 (format "~a=; Path=/; Max-Age=0; Secure; HttpOnly; SameSite=Strict" @@ -341,10 +355,15 @@ ; empty. ; result : A new auth-manager with normalized usernames and parsed networks. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (make-auth-manager user-pairs - #:trusted-proxies - [trusted-proxy-values '("127.0.0.0/8" "::1/128")] - #:session-seconds [session-seconds 604800]) +(define/contract (make-auth-manager + user-pairs + #:trusted-proxies + [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) (raise-argument-error 'make-auth-manager "exact-positive-integer?" session-seconds)) diff --git a/public/rkt-web-player.png b/public/rkt-web-player.png new file mode 100644 index 0000000..429a5cc Binary files /dev/null and b/public/rkt-web-player.png differ diff --git a/scribblings/rkt-web-player.scrbl b/scribblings/rkt-web-player.scrbl index 4f13b1c..df05e7b 100644 --- a/scribblings/rkt-web-player.scrbl +++ b/scribblings/rkt-web-player.scrbl @@ -4,6 +4,7 @@ racket/contract rkt-web-player rkt-web-player/player-agent + rkt-web-player/set-user rkt-web-player/users)) @title{RKT Web Player} @@ -77,6 +78,15 @@ Creates a salted Argon2id password hash suitable for a value in the INI 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] @defproc[(run-player-agent) any/c] { @@ -87,8 +97,10 @@ configured RKT Web Player server, downloads assigned tracks over HTTP, and 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 function must be called explicitly. -The GUI and optional tray support the same ten languages based on the -operating-system language, with English as fallback. +The GUI and its @tt{racket-tray} system tray support the same ten languages +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 diff --git a/set-user.rkt b/set-user.rkt index cefb152..98b1159 100644 --- a/set-user.rkt +++ b/set-user.rkt @@ -1,24 +1,36 @@ #lang racket/base -(require "users.rkt" - simple-ini/class) +(require racket/class + racket/contract + simple-ini/class + "users.rkt") (provide set-user) -(define (set-user) - (displayln "Using rkt-web-player.ini as configuration file") - (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) - ) - ) - - - +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Provided functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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)))) diff --git a/skill/racket-skill.md b/skill/racket-skill.md deleted file mode 100644 index 4674b22..0000000 --- a/skill/racket-skill.md +++ /dev/null @@ -1,227 +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 : -; pre : -; post : -; [result:] - -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 van `let`, `let*`, `letrec`, `if`, `when`, `unless`, `begin` en `cond` heeft de voorkeur. -- `map`, `filter`, en dat soort constructies gaan boven meer abstracte constructies als `for/or`, etc. -- Gebruik bij voorkeur geen `define` binnen een procedure, tenzij het echt om een locale - functie definitie gaat die een dermate omvang krijgt dat het binnen de closure gerechtvaardigd is. -- `let-values` is prima om te gebruiken. -- 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 `. - -