refactoring volgens skill
This commit is contained in:
@@ -25,3 +25,4 @@ rkt-web-player.ini
|
||||
|
||||
# Runtime playlist keystore
|
||||
data/*.keystore*
|
||||
/.scribble-build
|
||||
|
||||
+4
-3
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -18,6 +18,7 @@
|
||||
"racket-audio-dlna"
|
||||
"racket-mimetypes"
|
||||
"racket-sonos"
|
||||
"racket-tray"
|
||||
"racket-upnp"
|
||||
"simple-ini"
|
||||
"simple-log"
|
||||
|
||||
@@ -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 ";")))
|
||||
|
||||
+109
-75
@@ -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)
|
||||
|
||||
+19
-4
@@ -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
|
||||
|
||||
+14
-14
@@ -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)))
|
||||
|
||||
|
||||
+3
-3
@@ -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)))
|
||||
|
||||
@@ -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))))
|
||||
|
||||
+296
-260
@@ -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)))
|
||||
|
||||
+374
-236
@@ -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)))
|
||||
|
||||
@@ -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!)))))
|
||||
+4
-4
@@ -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)))
|
||||
|
||||
@@ -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))))
|
||||
|
||||
+76
-57
@@ -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))
|
||||
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 60 KiB |
@@ -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
|
||||
|
||||
+30
-18
@@ -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))))
|
||||
|
||||
@@ -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 : <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 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 <package>`.
|
||||
|
||||
|
||||
Reference in New Issue
Block a user