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

refactoring volgens skill

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-29 22:25:06 +02:00
parent 09121df0d7
commit b3a5a0b345
20 changed files with 1043 additions and 998 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+1
View File
@@ -25,3 +25,4 @@ rkt-web-player.ini
# Runtime playlist keystore # Runtime playlist keystore
data/*.keystore* data/*.keystore*
/.scribble-build
ARCHITECTURE.md
+4 -3
View File
@@ -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. not be treated as strong authentication when transported over unencrypted HTTP.
The GUI and CLI playback agents share one headless runtime. The GUI only adapts The GUI and CLI playback agents share one headless runtime. The GUI only adapts
configuration and state to widgets. Optional tray integration is loaded configuration and state to widgets. It uses `racket-tray` directly for its
dynamically through SDL3, so CLI use and the default GUI installation do not native tray icon, symbolic Open/Exit menu and portable hide-on-minimize
acquire a mandatory SDL dependency. behaviour. The previous SDL3 adapter and its update timer are no longer part of
the process.
The configured library roots define the intended filesystem boundary. Clients The configured library roots define the intended filesystem boundary. Clients
operate on opaque indexes instead of sending paths directly. The DLNA backend operate on opaque indexes instead of sending paths directly. The DLNA backend
README.md
+10 -12
View File
@@ -193,22 +193,20 @@ opgeruimd zodra ze niet meer nodig zijn en bij afsluiten van de agent.
### Systeemvak ### Systeemvak
De GUI gebruikt optioneel de open-source SDL3-tray-API. Als zowel het Racket- De GUI gebruikt het Racket-pakket `racket-tray`. Minimaliseren en de
pakket `sdl3` als de native SDL3-, SDL3_image- en SDL3_ttf-libraries aanwezig vensterknop verbergen de agent in het systeemvak. Het menu bevat
zijn, sluit de vensterknop de agent naar het systeemvak. Het menu bevat **RKT Web Player Agent openen** en **Afsluiten**; openen herstelt ook een
**RKT Web Player Agent openen** en **Afsluiten**. Zonder SDL3 blijft de agent geminimaliseerd venster. De tray is onderdeel van de normale package-
gewoon werken en sluit de vensterknop het proces af. Er wordt geen PowerShell- dependencies en vereist geen SDL3-pakket of SDL3-libraries meer.
proces of externe tray-helper gestart.
Windows en macOS gebruiken de native systeemvoorzieningen zonder aanvullende
runtime. Op Linux gebruikt `racket-tray` Ayatana AppIndicator voor GTK3. Op
Debian en Ubuntu kan die runtime zo worden geïnstalleerd:
```console ```console
raco pkg install sdl3 sudo apt install libayatana-appindicator3-1
``` ```
SDL3 is bewust geen verplichte package-dependency: de agent blijft daardoor
klein voor gebruikers die geen systeemvak nodig hebben. Op Windows moeten de
bijbehorende native DLL's daarnaast vindbaar zijn, bijvoorbeeld naast het
gebouwde executable of via `PATH`.
### CLI playback agent ### CLI playback agent
De headless agent gebruikt exact dezelfde polling-, download-, audio- en De headless agent gebruikt exact dezelfde polling-, download-, audio- en
info.rkt
+1
View File
@@ -18,6 +18,7 @@
"racket-audio-dlna" "racket-audio-dlna"
"racket-mimetypes" "racket-mimetypes"
"racket-sonos" "racket-sonos"
"racket-tray"
"racket-upnp" "racket-upnp"
"simple-ini" "simple-ini"
"simple-log" "simple-log"
main.rkt
+1 -1
View File
@@ -36,7 +36,7 @@
(define (configuration-list value defaults) (define (configuration-list value defaults)
(cond (cond
((list? value) (map (lambda (item) (format "~a" item)) value)) ((list? value) (map (λ (item) (format "~a" item)) value))
((and (string? value) ((and (string? value)
(not (string=? (string-trim value) ""))) (not (string=? (string-trim value) "")))
(map string-trim (string-split value ";"))) (map string-trim (string-split value ";")))
player-agent-cli.rkt
+109 -75
View File
@@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require racket/cmdline (require racket/cmdline
racket/contract
racket/format racket/format
racket/string racket/string
simple-log simple-log
@@ -9,87 +10,120 @@
(provide run-player-agent-cli) (provide run-player-agent-cli)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Produce a concise description of the current agent track.
; pre : track is #f or a server-supplied track hash.
; post : No state is changed.
; result : Artist and title when available, otherwise title or filename.
; internals:
; The CLI deliberately uses server metadata and does not reopen the
; downloaded media file solely for display purposes.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (track-description track) (define (track-description track)
(cond (cond
((not track) "geen track") ((not track) "geen track")
(else (else
(define title (hash-ref track 'title #f)) (let ((title (hash-ref track 'title #f))
(define artist (hash-ref track 'artist #f)) (artist (hash-ref track 'artist #f))
(define filename (hash-ref track 'filename "onbekend")) (filename (hash-ref track 'filename "onbekend")))
(cond (cond
((and artist title (not (string=? artist ""))) ((and artist title (not (string=? artist "")))
(format "~a — ~a" artist title)) (format "~a — ~a" artist title))
(title title) (title title)
(else filename))))) (else filename))))))
(define (run-player-agent-cli #:server-url [server-override #f] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#:name [name-override #f] ;; Provided functions
#:config-file [config-file #f]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Run the headless polling playback agent.
; pre : Overrides are #f or valid strings/paths and the configured server
; is reachable for useful operation.
; post : Configuration is persisted; runtime resources are released after
; interruption or an exception.
; result : Void after the agent has shut down.
; internals:
; One monitor thread prints only changed playback summaries. The
; shared runtime owns polling, downloads, audio and prefetch state.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (run-player-agent-cli #:server-url [server-override #f]
#:name [name-override #f]
#:config-file [config-file #f])
(->* ()
(#:server-url (or/c string? #f)
#:name (or/c string? #f)
#:config-file (or/c path-string? #f))
void?)
(sl-log-to-display) (sl-log-to-display)
(define loaded (let* ((loaded
(if config-file (if config-file
(load-player-agent-config config-file) (load-player-agent-config config-file)
(load-player-agent-config))) (load-player-agent-config)))
(define server-url (server-url
(string-trim (or server-override (string-trim (or server-override
(player-agent-config-server-url loaded)))) (player-agent-config-server-url loaded))))
(define name (name
(string-trim (or name-override (string-trim (or name-override
(player-agent-config-name loaded)))) (player-agent-config-name loaded))))
(define config (config
(struct-copy player-agent-config loaded (struct-copy player-agent-config loaded
(server-url server-url) (server-url server-url)
(name name))) (name name)))
(save-player-agent-config! config) (write-status
(λ (message)
(define (write-status message) (printf "[agent] ~a~n" message)
(printf "[agent] ~a~n" message) (flush-output)))
(flush-output)) (runtime
(make-player-agent-runtime
(define runtime server-url
(make-player-agent-runtime name
server-url (player-agent-config-app-id config)
name #:status-callback write-status
(player-agent-config-app-id config) #:denied-callback
#:status-callback write-status (λ (message)
#:denied-callback (eprintf "~a~n" message)
(lambda (message) (flush-output (current-error-port)))))
(eprintf "~a~n" message) (monitor #f))
(flush-output (current-error-port))))) (save-player-agent-config! config)
(printf "RKT Web Player CLI Agent~n")
(printf "RKT Web Player CLI Agent~n") (printf "Naam: ~a~n" name)
(printf "Naam: ~a~n" name) (printf "Server: ~a~n" server-url)
(printf "Server: ~a~n" server-url) (printf "Applicatie-ID: ~a~n" (player-agent-config-app-id config))
(printf "Applicatie-ID: ~a~n" (player-agent-config-app-id config)) (printf "Stoppen: Ctrl+C~n")
(printf "Stoppen: Ctrl+C~n") (flush-output)
(flush-output) (dynamic-wind
(λ ()
(define monitor #f) ((player-agent-runtime-start! runtime))
(dynamic-wind (set! monitor
(lambda () (thread
((player-agent-runtime-start! runtime)) (λ ()
(set! monitor (let loop ((previous #f))
(thread (let* ((snapshot
(lambda () ((player-agent-runtime-snapshot runtime)))
(let loop ((previous #f)) (summary
(define snapshot (cons
((player-agent-runtime-snapshot runtime))) (hash-ref snapshot 'state "stopped")
(define summary (track-description
(cons (hash-ref snapshot 'state "stopped") ((player-agent-runtime-current-track runtime))))))
(track-description (unless (equal? summary previous)
((player-agent-runtime-current-track runtime))))) (printf "[playback] ~a — ~a~n"
(unless (equal? summary previous) (car summary)
(printf "[playback] ~a — ~a~n" (car summary) (cdr summary)) (cdr summary))
(flush-output)) (flush-output))
(sleep 1) (sleep 1)
(loop summary)))))) (loop summary)))))))
(lambda () (λ ()
(with-handlers ((exn:break? void)) (with-handlers ((exn:break? void))
(sync never-evt))) (sync never-evt)))
(lambda () (λ ()
(when (and monitor (not (thread-dead? monitor))) (when (and monitor (not (thread-dead? monitor)))
(kill-thread monitor)) (kill-thread monitor))
((player-agent-runtime-shutdown! runtime))))) ((player-agent-runtime-shutdown! runtime))))))
(module+ main (module+ main
(define server-url #f) (define server-url #f)
player-agent.rkt
+19 -4
View File
@@ -1,5 +1,8 @@
#lang racket/base #lang racket/base
(require racket/class
racket/contract)
(provide run-player-agent (provide run-player-agent
run-player-agent-cli) run-player-agent-cli)
@@ -8,8 +11,12 @@
; pre : A graphical desktop is available. ; pre : A graphical desktop is available.
; post : The agent remains active until its window is closed. ; post : The agent remains active until its window is closed.
; result : The GUI frame returned by the implementation. ; result : The GUI frame returned by the implementation.
; internals:
; The GUI module is loaded only when this procedure is called. This
; keeps command-line use independent of racket/gui initialization.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (run-player-agent) (define/contract (run-player-agent)
(-> object?)
((dynamic-require "private/player-agent-gui.rkt" ((dynamic-require "private/player-agent-gui.rkt"
'run-player-agent-gui))) 'run-player-agent-gui)))
@@ -18,10 +25,18 @@
; pre : The configured server is reachable. ; pre : The configured server is reachable.
; post : The agent remains active until interrupted. ; post : The agent remains active until interrupted.
; result : Void after the agent has shut down. ; result : Void after the agent has shut down.
; internals:
; Delayed loading keeps the graphical and headless entrypoints
; separate while preserving the existing public module API.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (run-player-agent-cli #:server-url [server-url #f] (define/contract (run-player-agent-cli #:server-url [server-url #f]
#:name [name #f] #:name [name #f]
#:config-file [config-file #f]) #:config-file [config-file #f])
(->* ()
(#:server-url (or/c string? #f)
#:name (or/c string? #f)
#:config-file (or/c path-string? #f))
void?)
((dynamic-require "player-agent-cli.rkt" 'run-player-agent-cli) ((dynamic-require "player-agent-cli.rkt" 'run-player-agent-cli)
#:server-url server-url #:server-url server-url
#:name name #:name name
private/dlna-playback.rkt
+14 -14
View File
@@ -77,7 +77,7 @@
(list-ref (current-tracks playback) index))) (list-ref (current-tracks playback) index)))
(define (normalized-file file) (define (normalized-file file)
(with-handlers ((exn:fail? (lambda (_) (format "~a" file)))) (with-handlers ((exn:fail? (λ (_) (format "~a" file))))
(path->string (path->complete-path file)))) (path->string (path->complete-path file))))
(define (same-file? first second) (define (same-file? first second)
@@ -136,7 +136,7 @@
((not (equal? following (dlna-playback-prepared-index playback))) ((not (equal? following (dlna-playback-prepared-index playback)))
(with-handlers (with-handlers
((exn:fail? ((exn:fail?
(lambda (exception) (λ (exception)
(set-dlna-playback-prepared-index! playback #f) (set-dlna-playback-prepared-index! playback #f)
(warn-web-player-dlna (warn-web-player-dlna
"Could not prepare next DLNA track: ~a" "Could not prepare next DLNA track: ~a"
@@ -155,7 +155,7 @@
"index" index)) "index" index))
(with-handlers (with-handlers
((exn:fail? ((exn:fail?
(lambda (exception) (λ (exception)
(report-failure! playback (exn-message exception)) (report-failure! playback (exn-message exception))
(raise exception)))) (raise exception))))
(dlna-player-play! (dlna-playback-player playback) (track-file item)) (dlna-player-play! (dlna-playback-player playback) (track-file item))
@@ -286,11 +286,11 @@
(when (dlna-playback-running? playback) (when (dlna-playback-running? playback)
(with-handlers (with-handlers
((exn:fail? ((exn:fail?
(lambda (exception) (λ (exception)
(warn-web-player-dlna (warn-web-player-dlna
"Could not update DLNA playback state: ~a" "Could not update DLNA playback state: ~a"
(exn-message exception))))) (exn-message exception)))))
(with-lock playback (lambda () (poll/locked! playback)))) (with-lock playback (λ () (poll/locked! playback))))
(loop))))) (loop)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -319,26 +319,26 @@
playback) playback)
(define (dlna-playback-play-index! playback index) (define (dlna-playback-play-index! playback index)
(with-lock playback (lambda () (play-index/locked! playback index)))) (with-lock playback (λ () (play-index/locked! playback index))))
(define (dlna-playback-pause! playback) (define (dlna-playback-pause! playback)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-pause! (dlna-playback-player playback)) (dlna-player-pause! (dlna-playback-player playback))
(notify! playback 'paused (dlna-player-info (dlna-playback-player playback)))))) (notify! playback 'paused (dlna-player-info (dlna-playback-player playback))))))
(define (dlna-playback-resume! playback) (define (dlna-playback-resume! playback)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-resume! (dlna-playback-player playback)) (dlna-player-resume! (dlna-playback-player playback))
(notify! playback 'playing (dlna-player-info (dlna-playback-player playback)))))) (notify! playback 'playing (dlna-player-info (dlna-playback-player playback))))))
(define (dlna-playback-stop! playback) (define (dlna-playback-stop! playback)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(set-dlna-playback-stop-requested?! playback #t) (set-dlna-playback-stop-requested?! playback #t)
(set-dlna-playback-playing-seen?! playback #f) (set-dlna-playback-playing-seen?! playback #f)
(set-dlna-playback-progress-seen?! playback #f) (set-dlna-playback-progress-seen?! playback #f)
@@ -351,7 +351,7 @@
(define (dlna-playback-seek-percentage! playback percentage) (define (dlna-playback-seek-percentage! playback percentage)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-seek-percentage! (dlna-playback-player playback) percentage) (dlna-player-seek-percentage! (dlna-playback-player playback) percentage)
;; racket-audio-dlna updates its cache synchronously after Seek. Publish ;; racket-audio-dlna updates its cache synchronously after Seek. Publish
;; that value immediately so the web slider does not jump back. ;; that value immediately so the web slider does not jump back.
@@ -363,7 +363,7 @@
(define (dlna-playback-volume! playback percentage) (define (dlna-playback-volume! playback percentage)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-volume! (dlna-playback-player playback) percentage) (dlna-player-volume! (dlna-playback-player playback) percentage)
(define info (dlna-player-info (dlna-playback-player playback))) (define info (dlna-player-info (dlna-playback-player playback)))
(notify! playback (notify! playback
@@ -373,7 +373,7 @@
(define (dlna-playback-repeat! playback repeat) (define (dlna-playback-repeat! playback repeat)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(set-dlna-playback-repeat! playback repeat) (set-dlna-playback-repeat! playback repeat)
(set-dlna-playback-prepared-index! playback #f) (set-dlna-playback-prepared-index! playback #f)
(prepare-next! playback)))) (prepare-next! playback))))
@@ -387,7 +387,7 @@
(set-dlna-playback-monitor! playback #f) (set-dlna-playback-monitor! playback #f)
(with-lock (with-lock
playback playback
(lambda () (λ ()
(dlna-player-close! (dlna-playback-player playback)))))) (dlna-player-close! (dlna-playback-player playback))))))
(module+ test (module+ test
@@ -400,7 +400,7 @@
(track (build-path "music" "02.flac") (track (build-path "music" "02.flac")
"Second" "Artist" "Album" 60 "audio/flac")) "Second" "Artist" "Album" 60 "audio/flac"))
(define playback (define playback
(dlna-playback #f (lambda () (list first second)) void void (dlna-playback #f (λ () (list first second)) void void
'off 0 #f #f #f #f #f #f 0 #f #t #f #f 'off 0 #f #f #f #f #f #f 0 #f #t #f #f
(make-semaphore 1))) (make-semaphore 1)))
private/library.rkt
+3 -3
View File
@@ -139,12 +139,12 @@
(file-exists? file) (file-exists? file)
(audio-file? file) (audio-file? file)
(let ((full-file (let ((full-file
(with-handlers ((exn:fail? (lambda (_) #f))) (with-handlers ((exn:fail? (λ (_) #f)))
(simplify-path (path->complete-path file) #t)))) (simplify-path (path->complete-path file) #t))))
(and full-file (and full-file
(for/or ((library (in-list libraries))) (for/or ((library (in-list libraries)))
(define root (define root
(with-handlers ((exn:fail? (lambda (_) #f))) (with-handlers ((exn:fail? (λ (_) #f)))
(simplify-path (simplify-path
(path->complete-path (music-library-root library)) (path->complete-path (music-library-root library))
#t))) #t)))
@@ -185,7 +185,7 @@
(list name (list name
(normal-case-path (normal-case-path
(path->complete-path path))))) (path->complete-path path)))))
(lambda (first second) (λ (first second)
(equal? (cadr first) (cadr second)))))) (equal? (cadr first) (cadr second))))))
(for/list ((named-root (in-list roots)) (for/list ((named-root (in-list roots))
(index (in-naturals))) (index (in-naturals)))
private/player-agent-config.rkt
+79 -38
View File
@@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require file/sha1 (require file/sha1
racket/contract
racket/os racket/os
racket/path racket/path
racket/random racket/random
@@ -14,35 +15,75 @@
(struct player-agent-config (file ini app-id server-url name) #:transparent) (struct player-agent-config (file ini app-id server-url name) #:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (fresh-app-id) (define (fresh-app-id)
(bytes->hex-string (crypto-random-bytes 32))) (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) (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)) ; goal : Load the playback-agent INI configuration.
(define configured-id (ini-get ini 'agent 'app-id #f)) ; pre : file is a writable path-string understood by simple-ini.
(define value ; post : Missing defaults and a generated application ID are persisted.
(player-agent-config ; result : A player-agent-config value containing normalized settings.
file ; internals:
ini ; Reusing the stored application ID preserves the server allowlist;
(if (valid-app-id? configured-id) ; only a missing or malformed identifier is replaced.
(string-downcase configured-id) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(fresh-app-id)) (define/contract (load-player-agent-config
(ini-get ini 'server 'url "http://127.0.0.1:8080") [file (get-ini-file 'rkt-web-player-agent)])
(ini-get ini 'agent 'name (->* () (path-string?) player-agent-config?)
(format "~a playback" (gethostname))))) (let* ((ini (file->ini file))
(save-player-agent-config! value) (configured-id (ini-get ini 'agent 'app-id #f))
value) (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)) ; goal : Persist a playback-agent configuration.
(ini-set! ini 'agent 'app-id (player-agent-config-app-id value)) ; pre : value is a player-agent-config with a writable file path.
(ini-set! ini 'agent 'name (player-agent-config-name value)) ; post : Its ID, name and server URL are stored in a private INI file.
(ini-set! ini 'server 'url (player-agent-config-server-url value)) ; result : The result returned by simple-ini's ini->file procedure.
(ini->file ini (player-agent-config-file value) #:private? #t)) ; 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 (module+ test
(require rackunit (require rackunit
@@ -52,18 +93,18 @@
(define test-file (build-path test-directory "agent.ini")) (define test-file (build-path test-directory "agent.ini"))
(dynamic-wind (dynamic-wind
void void
(lambda () (λ ()
(define first (load-player-agent-config test-file)) (let* ((first (load-player-agent-config test-file))
(check-true (valid-app-id? (player-agent-config-app-id first))) (changed
(define changed (struct-copy player-agent-config first
(struct-copy player-agent-config first (server-url "https://music.example.test")
(server-url "https://music.example.test") (name "Test output"))))
(name "Test output"))) (check-true (valid-app-id? (player-agent-config-app-id first)))
(save-player-agent-config! changed) (save-player-agent-config! changed)
(define second (load-player-agent-config test-file)) (let ((second (load-player-agent-config test-file)))
(check-equal? (player-agent-config-app-id second) (check-equal? (player-agent-config-app-id second)
(player-agent-config-app-id first)) (player-agent-config-app-id first))
(check-equal? (player-agent-config-server-url second) (check-equal? (player-agent-config-server-url second)
"https://music.example.test") "https://music.example.test")
(check-equal? (player-agent-config-name second) "Test output")) (check-equal? (player-agent-config-name second) "Test output"))))
(lambda () (delete-directory/files test-directory)))) (λ () (delete-directory/files test-directory))))
private/player-agent-core.rkt
+296 -260
View File
@@ -3,6 +3,7 @@
(require json (require json
net/url net/url
racket-audio racket-audio
racket/contract
racket/file racket/file
racket/path racket/path
racket/port racket/port
@@ -17,6 +18,15 @@
(struct exn:fail:agent-denied exn:fail () #:transparent) (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 (struct player-agent-runtime
(start! reconnect! shutdown! snapshot current-track running? app-id) (start! reconnect! shutdown! snapshot current-track running? app-id)
#:transparent) #:transparent)
@@ -29,26 +39,27 @@
(combine-url/relative (base-url base) path)) (combine-url/relative (base-url base) path))
(define (post-json base path data) (define (post-json base path data)
(define input (let ((input
(post-pure-port (post-pure-port
(endpoint-url base path) (endpoint-url base path)
(jsexpr->bytes data) (jsexpr->bytes data)
(list "Content-Type: application/json" (list "Content-Type: application/json"
"Cache-Control: no-store"))) "Cache-Control: no-store"))))
(dynamic-wind (dynamic-wind
void void
(lambda () (λ ()
(define response (read-json input)) (let ((response (read-json input)))
(when (and (hash? response) (when (and (hash? response)
(string? (hash-ref response 'error #f))) (string? (hash-ref response 'error #f)))
(if (equal? (hash-ref response 'code #f) "agent-not-authorized") (if (equal? (hash-ref response 'code #f)
(raise "agent-not-authorized")
(exn:fail:agent-denied (raise
(hash-ref response 'error) (exn:fail:agent-denied
(current-continuation-marks))) (hash-ref response 'error)
(error 'player-agent (hash-ref response 'error)))) (current-continuation-marks)))
response) (error 'player-agent (hash-ref response 'error))))
(lambda () (close-input-port input)))) response))
(λ () (close-input-port input)))))
(define (normal-state state) (define (normal-state state)
(cond (cond
@@ -59,49 +70,69 @@
(define (safe-delete-file file) (define (safe-delete-file file)
(when (and file (file-exists? file)) (when (and file (file-exists? file))
(with-handlers ((exn:fail? (with-handlers ((exn:fail?
(lambda (exception) (λ (exception)
(warn-player-agent (warn-player-agent
"Could not remove temporary media file ~a: ~a" "Could not remove temporary media file ~a: ~a"
file file
(exn-message exception))))) (exn-message exception)))))
(delete-file file)))) (delete-file file))))
(define (make-player-agent-runtime initial-server-url ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
initial-name ;; Provided functions
app-id ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#:status-callback
[status-callback void] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#:denied-callback ; goal : Create the headless polling and audio runtime for one agent.
[denied-callback void]) ; pre : Server URL, display name and application ID are strings; callbacks
(define server-url initial-server-url) ; accept the status/denial messages supplied to them.
(define assigned-name initial-name) ; post : Mutable state is initialized but no worker thread or audio backend
(define state-lock (make-semaphore 1)) ; is started until the returned start! procedure is called.
(define worker #f) ; result : A player-agent-runtime containing its lifecycle/query procedures.
(define command-worker #f) ; internals:
(define executing-command-id 0) ; One closure owns the simple mutable state shared by polling,
(define running #f) ; command and audio callbacks. Keeping these procedures together
(define authorization-notified? #f) ; makes their synchronization and cleanup order directly visible.
(define audio #f) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define current-media-key #f) (define/contract (make-player-agent-runtime initial-server-url
(define cached-media (make-hash)) initial-name
(define prefetched-track #f) app-id
(define auto-started-key #f) #:status-callback
(define pending-auto-music-id #f) [status-callback void]
(define music-tracks (make-hash)) #:denied-callback
(define current-track-value #f) [denied-callback void])
(define acknowledged-command 0) (->* (string? string? string?)
(define ended-counter 0) (#:status-callback (-> string? any/c)
(define logical-volume 50) #:denied-callback (-> string? any/c))
(define agent-state player-agent-runtime?)
(hasheq 'state "stopped" (let* ((server-url initial-server-url)
'position 0 (assigned-name initial-name)
'duration 'null (state-lock (make-semaphore 1))
'rate 'null (worker #f)
'channels 'null (command-worker #f)
'bits 'null (executing-command-id 0)
'format "" (running #f)
'volume logical-volume (authorization-notified? #f)
'error 'null)) (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) (define (with-agent-state proc)
(call-with-semaphore state-lock proc)) (call-with-semaphore state-lock proc))
@@ -110,98 +141,98 @@
(if (eq? value #f) fallback value)) (if (eq? value #f) fallback value))
(define (snapshot) (define (snapshot)
(with-agent-state (lambda () agent-state))) (with-agent-state (λ () agent-state)))
(define (current-track) (define (current-track)
(with-agent-state (lambda () current-track-value))) (with-agent-state (λ () current-track-value)))
(define (set-agent-error! message) (define (set-agent-error! message)
(with-agent-state (with-agent-state
(lambda () (λ ()
(set! agent-state (hash-set agent-state 'error message))))) (set! agent-state (hash-set agent-state 'error message)))))
(define (clear-agent-error!) (define (clear-agent-error!)
(with-agent-state (with-agent-state
(lambda () (λ ()
(set! agent-state (hash-set agent-state 'error 'null))))) (set! agent-state (hash-set agent-state 'error 'null)))))
(define (update-from-audio! state full-state) (define (update-from-audio! state full-state)
(with-agent-state (with-agent-state
(lambda () (λ ()
(define audible-music-id (hash-ref full-state 'at-music-id #f)) (let ((audible-music-id (hash-ref full-state 'at-music-id #f)))
(set! agent-state (set! agent-state
(hasheq (hasheq
'state (normal-state state) 'state (normal-state state)
'position (state-value (hash-ref full-state 'at-second #f) 0) 'position (state-value (hash-ref full-state 'at-second #f) 0)
'duration (state-value (hash-ref full-state 'duration #f) 'null) 'duration (state-value (hash-ref full-state 'duration #f) 'null)
'rate (state-value (hash-ref full-state 'rate #f) 'null) 'rate (state-value (hash-ref full-state 'rate #f) 'null)
'channels (state-value (hash-ref full-state 'channels #f) 'null) 'channels (state-value (hash-ref full-state 'channels #f) 'null)
'bits (state-value (hash-ref full-state 'bits #f) 'null) 'bits (state-value (hash-ref full-state 'bits #f) 'null)
'format (let ((decoder (hash-ref full-state 'decoder #f))) 'format (let ((decoder (hash-ref full-state 'decoder #f)))
(if decoder (format "~a" decoder) "")) (if decoder (format "~a" decoder) ""))
'volume logical-volume 'volume logical-volume
'error 'null)) 'error 'null))
(when (and pending-auto-music-id (when (and pending-auto-music-id
(number? audible-music-id) (number? audible-music-id)
(= pending-auto-music-id audible-music-id)) (= pending-auto-music-id audible-music-id))
(define audible-track (let ((audible-track
(hash-ref music-tracks audible-music-id #f)) (hash-ref music-tracks audible-music-id #f)))
(when audible-track (when audible-track
(set! current-track-value audible-track) (set! current-track-value audible-track)
(hash-clear! music-tracks) (hash-clear! music-tracks)
(hash-set! music-tracks audible-music-id audible-track)) (hash-set! music-tracks audible-music-id audible-track)))
(set! pending-auto-music-id #f) (set! pending-auto-music-id #f)
(set! ended-counter (+ ended-counter 1)))))) (set! ended-counter (+ ended-counter 1)))))))
(define (ensure-audio!) (define (ensure-audio!)
(unless audio (unless audio
(set! audio (set! audio
(make-audio-player (make-audio-player
(lambda (_handle state full-state) (λ (_handle state full-state)
(update-from-audio! state full-state)) (update-from-audio! state full-state))
(lambda (handle) (λ (handle)
(advance-at-decoder-eof! handle)))) (advance-at-decoder-eof! handle))))
(audio-ao-buf-ms! audio 500) (audio-ao-buf-ms! audio 500)
(audio-buf-seconds! audio 4 10) (audio-buf-seconds! audio 4 10)
(define scaled (/ logical-volume 100.0)) (let ((scaled (/ logical-volume 100.0)))
(audio-volume! audio (* 100.0 scaled scaled))) (audio-volume! audio (* 100.0 scaled scaled))))
audio) audio)
(define (download-media! token filename) (define (download-media! token filename)
(define extension (let* ((extension
(or (path-get-extension (string->path filename)) #"")) (or (path-get-extension (string->path filename)) #""))
(define target (target
(make-temporary-file (make-temporary-file
(string-append "rkt-player-agent-~a" (string-append "rkt-player-agent-~a"
(bytes->string/utf-8 extension)))) (bytes->string/utf-8 extension))))
(define path (format "/api/agent/media/~a/~a" app-id token)) (path (format "/api/agent/media/~a/~a" app-id token))
(define input (get-pure-port (endpoint-url server-url path))) (input (get-pure-port (endpoint-url server-url path))))
(with-handlers ((exn:fail? (with-handlers ((exn:fail?
(lambda (exception) (λ (exception)
(close-input-port input) (close-input-port input)
(safe-delete-file target) (safe-delete-file target)
(raise exception)))) (raise exception))))
(call-with-output-file (call-with-output-file
target target
(lambda (output) (copy-port input output)) (λ (output) (copy-port input output))
#:exists 'truncate/replace) #:exists 'truncate/replace)
(close-input-port input) (close-input-port input)
target)) target)))
(define (command-cache-key data) (define (command-cache-key data)
(hash-ref data 'cacheKey (hash-ref data 'mediaToken))) (hash-ref data 'cacheKey (hash-ref data 'mediaToken)))
(define (ensure-media-cached! data) (define (ensure-media-cached! data)
(define key (command-cache-key data)) (let* ((key (command-cache-key data))
(define found (hash-ref cached-media key #f)) (found (hash-ref cached-media key #f)))
(if (and found (file-exists? found)) (if (and found (file-exists? found))
found found
(let ((downloaded (let ((downloaded
(download-media! (download-media!
(hash-ref data 'mediaToken) (hash-ref data 'mediaToken)
(hash-ref data 'filename "track")))) (hash-ref data 'filename "track"))))
(hash-set! cached-media key downloaded) (hash-set! cached-media key downloaded)
downloaded))) downloaded))))
(define (discard-unused-media! keep-key) (define (discard-unused-media! keep-key)
(for ((entry (in-list (hash->list cached-media)))) (for ((entry (in-list (hash->list cached-media))))
@@ -212,130 +243,134 @@
;; Decoder EOF occurs before audible EOF. Queueing the prefetched decoder at ;; Decoder EOF occurs before audible EOF. Queueing the prefetched decoder at
;; this point appends it behind racket-audio's remaining output buffer. ;; this point appends it behind racket-audio's remaining output buffer.
(define (advance-at-decoder-eof! handle) (define (advance-at-decoder-eof! handle)
(define prepared (let ((prepared
(with-agent-state (with-agent-state
(lambda () (λ ()
(define value prefetched-track) (let ((value prefetched-track))
(set! prefetched-track #f) (set! prefetched-track #f)
value))) value)))))
(cond (cond
(prepared (prepared
(define data (car prepared)) (let* ((data (car prepared))
(define path (cdr prepared)) (path (cdr prepared))
(define key (command-cache-key data)) (key (command-cache-key data)))
(with-handlers (with-handlers
((exn:fail? ((exn:fail?
(lambda (exception) (λ (exception)
(warn-player-agent "Could not start prefetched track: ~a" (warn-player-agent "Could not start prefetched track: ~a"
(exn-message exception)) (exn-message exception))
(set-agent-error! (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 (with-agent-state
(lambda () (set! ended-counter (+ ended-counter 1))))))) (λ ()
(define music-id (audio-play! handle path)) (hash-set! music-tracks music-id data)
(info-player-agent "Queued prefetched track ~a as music id ~a" (set! auto-started-key key)
(hash-ref data 'filename "track") (set! pending-auto-music-id music-id)))))))
music-id) (else
(set! current-media-key key) (warn-player-agent
(discard-unused-media! key) "Decoder reached EOF before the next track was prefetched")
(with-agent-state (with-agent-state
(lambda () (λ () (set! ended-counter (+ ended-counter 1))))))))
(hash-set! music-tracks music-id data)
(set! auto-started-key key)
(set! pending-auto-music-id music-id)))))
(else
(warn-player-agent
"Decoder reached EOF before the next track was prefetched")
(with-agent-state
(lambda () (set! ended-counter (+ ended-counter 1)))))))
(define (execute-command! command) (define (execute-command! command)
(define action (hash-ref command 'action "")) (let ((action (hash-ref command 'action ""))
(define data (hash-ref command 'data (hasheq))) (data (hash-ref command 'data (hasheq))))
(info-player-agent "Executing command ~a" action) (info-player-agent "Executing command ~a" action)
(cond (cond
((string=? action "play") ((string=? action "play")
(define next-key (command-cache-key data)) (let* ((next-key (command-cache-key data))
(define already-started? (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 (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! prefetched-track #f)
(set! auto-started-key #f) (set! auto-started-key #f)
(set! pending-auto-music-id #f) (set! pending-auto-music-id #f)))
(set! agent-state (when audio
(hash-set (audio-stop! audio)))
(hash-set agent-state 'state "starting") ((string=? action "seek")
'error 'null)))) (audio-seek! (ensure-audio!) (hash-ref data 'percentage 0)))
(define next-media (ensure-media-cached! data)) ((string=? action "volume")
;; audio-play! interrupts and closes the previous decoder itself. (set! logical-volume (min 100 (max 0 (hash-ref data 'value 50))))
(define music-id (audio-play! (ensure-audio!) next-media)) (let ((scaled (/ logical-volume 100.0)))
(audio-volume! (ensure-audio!) (* 100.0 scaled scaled)))
(with-agent-state (with-agent-state
(lambda () (λ ()
(hash-clear! music-tracks) (set! agent-state
(hash-set! music-tracks music-id data))) (hash-set agent-state 'volume logical-volume)))))
(set! current-media-key next-key) (else
(discard-unused-media! next-key))) (error 'player-agent "unknown command: ~a" action)))))
((string=? action "prefetch")
(define key (command-cache-key data))
(define path (ensure-media-cached! data))
(with-agent-state
(lambda () (set! prefetched-track (cons data path))))
(info-player-agent "Prefetched ~a" (hash-ref data 'filename "track"))
(for ((entry (in-list (hash->list cached-media))))
(unless (or (equal? (car entry) current-media-key)
(equal? (car entry) key))
(safe-delete-file (cdr entry))
(hash-remove! cached-media (car entry)))))
((string=? action "pause")
(audio-pause! (ensure-audio!) #t))
((string=? action "resume")
(audio-pause! (ensure-audio!) #f))
((string=? action "stop")
(with-agent-state
(lambda ()
(set! prefetched-track #f)
(set! auto-started-key #f)
(set! pending-auto-music-id #f)))
(when audio (audio-stop! audio)))
((string=? action "seek")
(audio-seek! (ensure-audio!) (hash-ref data 'percentage 0)))
((string=? action "volume")
(set! logical-volume (min 100 (max 0 (hash-ref data 'value 50))))
(define scaled (/ logical-volume 100.0))
(audio-volume! (ensure-audio!) (* 100.0 scaled scaled))
(with-agent-state
(lambda ()
(set! agent-state
(hash-set agent-state 'volume logical-volume)))))
(else
(error 'player-agent "unknown command: ~a" action))))
(define (poll-loop) (define (poll-loop)
(with-handlers (with-handlers
((exn:fail:agent-denied? ((exn:fail:agent-denied?
(lambda (exception) (λ (exception)
(define message (format (tr 'denied-message) app-id)) (let ((message (format (tr 'denied-message) app-id)))
(warn-player-agent "Agent authorization refused: ~a" (warn-player-agent "Agent authorization refused: ~a"
(exn-message exception)) (exn-message exception))
(set-agent-error! message) (set-agent-error! message)
(status-callback (status-callback
(tr 'unauthorized-status)) (tr 'unauthorized-status))
(unless authorization-notified? (unless authorization-notified?
(set! authorization-notified? #t) (set! authorization-notified? #t)
(denied-callback message)) (denied-callback message))
(when running (when running
(sleep 3) (sleep 3)
(poll-loop)))) (poll-loop)))))
(exn:fail? (exn:fail?
(lambda (exception) (λ (exception)
(warn-player-agent "Connection cycle failed: ~a" (warn-player-agent "Connection cycle failed: ~a"
(exn-message exception)) (exn-message exception))
(set-agent-error! (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) (info-player-agent "Registered at ~a as ~a" server-url assigned-name)
(let loop () (let loop ()
(when running (when running
(define response (let* ((response
(post-json (post-json
server-url server-url
"/api/agent/poll" "/api/agent/poll"
(hasheq 'appId app-id (hasheq 'appId app-id
'name assigned-name 'name assigned-name
'ack acknowledged-command 'ack acknowledged-command
'endedCounter ended-counter 'endedCounter ended-counter
'state (snapshot)))) 'state (snapshot))))
(define command (hash-ref response 'command 'null)) (command (hash-ref response 'command 'null)))
(when (and (hash? command) (when (and (hash? command)
(> (hash-ref command 'id 0) acknowledged-command) (> (hash-ref command 'id 0) acknowledged-command)
(not (= (hash-ref command 'id 0) executing-command-id))) (not (= (hash-ref command 'id 0)
(set! executing-command-id (hash-ref command 'id)) executing-command-id)))
(set! command-worker (set! executing-command-id (hash-ref command 'id))
(thread (set! command-worker
(lambda () (thread
(with-handlers (λ ()
((exn:fail? (with-handlers
(lambda (exception) ((exn:fail?
(warn-player-agent "Command failed: ~a" (λ (exception)
(exn-message exception)) (warn-player-agent "Command failed: ~a"
(set-agent-error! (exn-message exception))))) (exn-message exception))
(clear-agent-error!) (set-agent-error! (exn-message exception)))))
(execute-command! command)) (clear-agent-error!)
(set! acknowledged-command (hash-ref command 'id)) (execute-command! command))
(set! executing-command-id 0) (set! acknowledged-command (hash-ref command 'id))
(set! command-worker #f))))) (set! executing-command-id 0)
(set! command-worker #f))))))
(sleep 1) (sleep 1)
(loop))))) (loop)))))
@@ -421,5 +457,5 @@
shutdown! shutdown!
snapshot snapshot
current-track current-track
(lambda () running) (λ () running)
app-id)) app-id)))
private/player-agent-gui.rkt
+374 -236
View File
@@ -1,15 +1,16 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/contract
racket/format racket/format
racket/gui/base racket/gui/base
racket/os racket/os
racket/path racket/runtime-path
racket/string racket/string
racket-tray
simple-log simple-log
"player-agent-config.rkt" "player-agent-config.rkt"
"player-agent-core.rkt" "player-agent-core.rkt"
"player-agent-tray.rkt"
"translate.rkt") "translate.rkt")
(provide run-player-agent-gui) (provide run-player-agent-gui)
@@ -20,256 +21,393 @@
(build-path (find-system-path 'pref-dir) (build-path (find-system-path 'pref-dir)
"rkt-web-player-agent.log")) "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 (input-field label init-value panel)
(define field (let ((field
(new text-field% (new text-field%
(parent panel) (parent panel)
(label label) (label label)
(init-value init-value))) (init-value init-value))))
(send (send field get-editor) set-padding 0 2 0 2) (send (send field get-editor) set-padding 0 2 0 2)
field) 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 (format-time value)
(define seconds (let* ((seconds
(if (and (number? value) (>= value 0)) (if (and (number? value) (>= value 0))
(inexact->exact (floor value)) (inexact->exact (floor value))
0)) 0))
(define hours (quotient seconds 3600)) (hours (quotient seconds 3600))
(define minutes (quotient (remainder seconds 3600) 60)) (minutes (quotient (remainder seconds 3600) 60))
(define remaining (remainder seconds 60)) (remaining (remainder seconds 60)))
(format "~a:~a:~a" (format "~a:~a:~a"
(~r hours #:min-width 2 #:pad-string "0") (~r hours #:min-width 2 #:pad-string "0")
(~r minutes #:min-width 2 #:pad-string "0") (~r minutes #:min-width 2 #:pad-string "0")
(~r remaining #: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) (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) ; goal : Queue a status-label update in the GUI eventspace.
(define runtime #f) ; pre : message is a string supplied by the agent runtime.
(define status-message #f) ; post : The status widget shows message when it has been created.
(define playback-message #f) ; result : Unspecified.
(define playback-details #f) ; internals:
(define playback-filename #f) ; Runtime callbacks can originate outside the GUI eventspace, so
(define name-field #f) ; widget access is always forwarded with queue-callback.
(define server-field #f) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define connect-button #f) (define (show-status! message)
(define playback-timer #f) (queue-callback
(define tray-timer #f) (λ ()
(define tray #f) (when status-message
(define shutting-down? #f) (send status-message set-label message)))
#f))
(define (show-status! message) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(queue-callback ; goal : Show a playback-agent authorization failure.
(lambda () ; pre : message is a string supplied by the agent runtime.
(when status-message ; post : A modal error dialog is queued for the agent frame.
(send status-message set-label message))) ; result : Unspecified.
#f)) ; 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) (set! runtime
(queue-callback (make-player-agent-runtime
(lambda () (player-agent-config-server-url config)
(message-box (tr 'denied-title) (player-agent-config-name config)
message (player-agent-config-app-id config)
frame #:status-callback show-status!
'(ok stop))) #:denied-callback show-denial!))
#f))
(set! runtime ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(make-player-agent-runtime ; goal : Refresh the visible playback summary from the runtime cache.
(player-agent-config-server-url config) ; pre : runtime exists; the widgets may still be uninitialized.
(player-agent-config-name config) ; post : Initialized playback widgets reflect one coherent cached
(player-agent-config-app-id config) ; snapshot and its current track.
#:status-callback show-status! ; result : Unspecified.
#:denied-callback show-denial!)) ; 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) ; goal : Persist edited connection settings and reconnect the runtime.
(define snapshot ((player-agent-runtime-snapshot runtime))) ; pre : The name, server and connect widgets have been initialized.
(define track ((player-agent-runtime-current-track runtime))) ; post : config and the INI file contain normalized values; the runtime
(define state (hash-ref snapshot 'state "stopped")) ; reconnects with them and the button becomes a reconnect button.
(define title (and track (hash-ref track 'title #f))) ; result : Unspecified.
(define artist (and track (hash-ref track 'artist #f))) ; internals:
(define filename (and track (hash-ref track 'filename #f))) ; An empty name receives the same hostname-based default used by
(define track-number (and track (hash-ref track 'trackNumber #f))) ; initial configuration loading.
(define track-label ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cond (define (reconnect!)
((and artist (not (string=? artist "")) title) (let* ((next-server (string-trim (send server-field get-value)))
(format "~a — ~a" artist title)) (entered-name (string-trim (send name-field get-value)))
(title title) (next-name
(else (tr 'no-track-selected)))) (if (string=? entered-name "")
(define prefix (format "~a playback" (gethostname))
(cond entered-name)))
((string=? state "playing") (tr 'playing)) (set! config
((string=? state "paused") (tr 'paused)) (struct-copy player-agent-config config
((string=? state "starting") (tr 'loading)) (server-url next-server)
((string=? state "stopped") (tr 'stopped)) (name next-name)))
(else state))) (save-player-agent-config! config)
(define position (hash-ref snapshot 'position 0)) (send name-field set-value next-name)
(define duration (hash-ref snapshot 'duration 'null)) ((player-agent-runtime-reconnect! runtime) next-server next-name)
(define format-name (hash-ref snapshot 'format "")) (send connect-button set-label (tr 'reconnect))))
(define rate (hash-ref snapshot 'rate 'null))
(define bits (hash-ref snapshot 'bits 'null))
(define channels (hash-ref snapshot 'channels 'null))
(define details
(filter
(lambda (value) (not (string=? value "")))
(list
(format "~a / ~a"
(format-time position)
(if (number? duration) (format-time duration) "--:--:--"))
(if (number? bits) (format "~a bit" bits) "")
(if (number? rate)
(format "~a kHz" (~r (/ rate 1000.0) #:precision '(= 1)))
"")
(if (number? channels)
(format "~a ~a" channels
(tr (if (= channels 1) 'channel 'channels)))
"")
(if (and (string? format-name) (not (string=? format-name "")))
format-name
""))))
(send playback-message
set-label
(if track
(format "~a~a: ~a"
prefix
(if (number? track-number)
(format " #~a" track-number)
"")
track-label)
(tr 'no-track)))
(send playback-details set-label (string-join details " · "))
(send playback-filename
set-label
(if (and (string? filename) (not (string=? filename "")))
filename
"—"))))
(define (reconnect!) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define next-server (string-trim (send server-field get-value))) ; goal : Release resources owned by the GUI agent exactly once.
(define entered-name (string-trim (send name-field get-value))) ; pre : runtime has been created; timer and tray may be #f.
(define next-name ; post : Playback polling, audio, the GUI timer and native tray resources
(if (string=? entered-name "") ; have stopped; subsequent calls do nothing.
(format "~a playback" (gethostname)) ; result : Unspecified.
entered-name)) ; internals:
(set! config ; The guard makes this procedure safe from both the window close
(struct-copy player-agent-config config ; path and the tray Exit action.
(server-url next-server) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(name next-name))) (define (shutdown!)
(save-player-agent-config! config) (unless shutting-down?
(send name-field set-value next-name) (set! shutting-down? #t)
((player-agent-runtime-reconnect! runtime) next-server next-name) (when playback-timer
(send connect-button set-label (tr 'reconnect))) (send playback-timer stop))
((player-agent-runtime-shutdown! runtime))
(when tray
(tray-close tray)
(set! tray #f))))
(define (shutdown!) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless shutting-down? ; goal : Terminate the graphical agent from its tray menu.
(set! shutting-down? #t) ; pre : frame and runtime have been initialized.
(when playback-timer (send playback-timer stop)) ; post : Resources are released and the frame is hidden.
(when tray-timer (send tray-timer stop)) ; result : Unspecified.
((player-agent-runtime-shutdown! runtime)) ; internals:
(when tray ; racket-tray invokes actions in the frame eventspace, so no
((tray-controller-destroy! tray)) ; additional GUI callback queue is needed here.
(set! tray #f)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (quit!)
(shutdown!)
(send frame show #f))
(define (quit!) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(queue-callback ; goal : Restore the agent frame from the tray.
(lambda () ; pre : frame has been initialized and has not been destroyed.
(shutdown!) ; post : frame is visible and no longer iconized.
(when frame (send frame show #f))) ; result : Unspecified.
#f)) ; 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% ; goal : Dispatch a symbolic racket-tray action.
(super-new) ; pre : action is installed in the tray menu below.
(define/augment (on-close) ; post : 'open restores the frame; 'exit shuts down the agent.
(if tray ; result : Unspecified.
(send this show #f) ; internals:
(begin ; One callback handles both direct tray activation and menu
(shutdown!) ; selection on every platform.
(inner (void) on-close)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-action! action)
(case action
((open) (show-window!))
((exit) (quit!))))
(set! frame (let* ((agent-frame%
(new agent-frame% (class frame%
(label (tr 'app-title)) (super-new)
(width 560) (define/augment (on-close)
(height 310))) (if tray
(define panel (send this show #f)
(new vertical-panel% (begin
(parent frame) (shutdown!)
(alignment '(left top)))) (inner (void) on-close))))))
(set! server-field (new-frame
(input-field (tr 'server) (new agent-frame%
(player-agent-config-server-url config) (label (tr 'app-title))
panel)) (width 560)
(set! name-field (height 310))))
(input-field (tr 'name) (player-agent-config-name config) panel)) (set! frame new-frame))
(define id-field
(input-field (tr 'application-id)
(player-agent-config-app-id config)
panel))
;; Lock the editor, not the native widget. Disabled Windows controls render
;; their label and text poorly on some display configurations.
(send (send id-field get-editor) lock #t)
(define playback-panel (let* ((panel
(new group-box-panel% (new vertical-panel%
(parent panel) (parent frame)
(label (tr 'playback)) (alignment '(left top))))
(alignment '(left top)) (server
(stretchable-height #f))) (input-field (tr 'server)
(set! playback-message (player-agent-config-server-url config)
(new message% panel))
(parent playback-panel) (name
(label (tr 'no-track)) (input-field (tr 'name)
(auto-resize #t))) (player-agent-config-name config)
(set! playback-details panel))
(new message% (id-field
(parent playback-panel) (input-field (tr 'application-id)
(label "00:00:00 / --:--:--") (player-agent-config-app-id config)
(auto-resize #t))) panel))
(set! playback-filename (playback-panel
(new message% (new group-box-panel%
(parent playback-panel) (parent panel)
(label "—") (label (tr 'playback))
(auto-resize #t))) (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 (set! playback-timer
(new horizontal-panel%
(parent panel)
(alignment '(left center))))
(set! connect-button
(new button%
(parent controls)
(label (tr 'save-connect))
(callback (lambda (_button _event) (reconnect!)))))
(set! status-message
(new message%
(parent controls)
(label (tr 'connecting))
(auto-resize #t)))
(set! playback-timer
(new timer%
(notify-callback refresh-playback-status!)
(interval 500)))
(refresh-playback-status!)
;; If SDL3 and its native runtime are present, closing the frame hides it in
;; the tray. Otherwise the original close-and-exit behaviour remains.
(set! tray
(try-make-tray-controller
(lambda ()
(queue-callback (lambda () (send frame show #t)) #f))
quit!))
(when tray
(set! tray-timer
(new timer% (new timer%
(notify-callback (tray-controller-update! tray)) (notify-callback refresh-playback-status!)
(interval 100)))) (interval 500)))
(refresh-playback-status!)
(send frame show #t) (set! tray
((player-agent-runtime-start! runtime)) (mk-tray frame
(send connect-button set-label (tr 'reconnect)) tray-icon
frame) (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)))
private/player-agent-tray.rkt
-36
View File
@@ -1,36 +0,0 @@
#lang racket/base
(require "translate.rkt")
;; SDL3 is deliberately loaded dynamically. The GUI agent keeps working
;; without the optional Racket package and native SDL3 runtime.
(provide (struct-out tray-controller)
try-make-tray-controller)
(struct tray-controller (update! destroy!) #:transparent)
(define (try-make-tray-controller show-window! quit!)
(with-handlers ((exn:fail? (lambda (_) #f)))
(define sdl-init! (dynamic-require 'sdl3 'sdl-init!))
(define sdl-quit! (dynamic-require 'sdl3 'sdl-quit!))
(define make-tray (dynamic-require 'sdl3 'make-tray))
(define make-tray-menu (dynamic-require 'sdl3 'make-tray-menu))
(define insert-tray-entry! (dynamic-require 'sdl3 'insert-tray-entry!))
(define set-tray-entry-callback!
(dynamic-require 'sdl3 'set-tray-entry-callback!))
(define update-trays! (dynamic-require 'sdl3 'update-trays!))
(define tray-destroy! (dynamic-require 'sdl3 'tray-destroy!))
(sdl-init! '(video events))
(define tray (make-tray #f (tr 'app-title)))
(define menu (make-tray-menu tray))
(define show-entry (insert-tray-entry! menu (tr 'tray-open)))
(insert-tray-entry! menu #f)
(define quit-entry (insert-tray-entry! menu (tr 'quit)))
(set-tray-entry-callback! show-entry (lambda (_) (show-window!)))
(set-tray-entry-callback! quit-entry (lambda (_) (quit!)))
(tray-controller
update-trays!
(lambda ()
(tray-destroy! tray)
(sdl-quit!)))))
private/player.rkt
+4 -4
View File
@@ -278,7 +278,7 @@
(hash-ref! (hash-ref!
(player-playlist-contexts value) (player-playlist-contexts value)
normalized normalized
(lambda () (new-playlist-context value normalized)))) (λ () (new-playlist-context value normalized))))
(define (context-tracks context) (define (context-tracks context)
(playlist-tab-tracks (playlist-tab-tracks
@@ -324,7 +324,7 @@
(define context (playlist-context-for! value normalized)) (define context (playlist-context-for! value normalized))
(with-state-lock (with-state-lock
value value
(lambda () (λ ()
(set-player-tabs! value (playlist-context-tabs context)) (set-player-tabs! value (playlist-context-tabs context))
(set-player-current-tab-index! (set-player-current-tab-index!
value value
@@ -1649,7 +1649,7 @@
(define item (define item
(call-with-semaphore (call-with-semaphore
(player-command-lock value) (player-command-lock value)
(lambda () (λ ()
(define context (define context
(playlist-context-for! (playlist-context-for!
value value
@@ -1659,7 +1659,7 @@
(player-tracks value) (player-tracks value)
(append-map playlist-tab-tracks (append-map playlist-tab-tracks
(playlist-context-tabs context)))) (playlist-context-tabs context))))
(findf (lambda (candidate) (findf (λ (candidate)
(string=? (track-cache-key candidate) artwork-id)) (string=? (track-cache-key candidate) artwork-id))
candidates)))) candidates))))
(and item (track-artwork item))) (and item (track-artwork item)))
private/playlists.rkt
+8 -8
View File
@@ -69,7 +69,7 @@
id id
name name
(filter-map (filter-map
(lambda (item) (datum->track item libraries)) (λ (item) (datum->track item libraries))
tracks)))))) tracks))))))
(define (open-playlist-store file) (define (open-playlist-store file)
@@ -82,7 +82,7 @@
(when store (when store
(call-with-semaphore (call-with-semaphore
(playlist-store-lock store) (playlist-store-lock store)
(lambda () (ks-close (playlist-store-keystore store))))) (λ () (ks-close (playlist-store-keystore store)))))
(void)) (void))
(define (load-user-playlists store username libraries) (define (load-user-playlists store username libraries)
@@ -90,12 +90,12 @@
'() '()
(call-with-semaphore (call-with-semaphore
(playlist-store-lock store) (playlist-store-lock store)
(lambda () (λ ()
(define ks (playlist-store-keystore store)) (define ks (playlist-store-keystore store))
(define ids (ks-get ks (user-playlists-key username) '())) (define ids (ks-get ks (user-playlists-key username) '()))
(if (list? ids) (if (list? ids)
(filter-map (filter-map
(lambda (id) (λ (id)
(datum->tab id (ks-get ks id #f) libraries)) (datum->tab id (ks-get ks id #f) libraries))
(remove-duplicates (filter uuid-string? ids) string=?)) (remove-duplicates (filter uuid-string? ids) string=?))
'()))))) '())))))
@@ -104,7 +104,7 @@
(when store (when store
(call-with-semaphore (call-with-semaphore
(playlist-store-lock store) (playlist-store-lock store)
(lambda () (λ ()
(define ks (playlist-store-keystore store)) (define ks (playlist-store-keystore store))
(define index-key (user-playlists-key username)) (define index-key (user-playlists-key username))
(define old-ids (ks-get ks index-key '())) (define old-ids (ks-get ks index-key '()))
@@ -174,13 +174,13 @@
(define outside (build-path root "outside.flac")) (define outside (build-path root "outside.flac"))
(define store-file (build-path root "data" "playlists.keystore")) (define store-file (build-path root "data" "playlists.keystore"))
(dynamic-wind (dynamic-wind
(lambda () (λ ()
(make-directory music) (make-directory music)
(make-directory music-two) (make-directory music-two)
(call-with-output-file (build-path music "one.flac") void) (call-with-output-file (build-path music "one.flac") void)
(call-with-output-file (build-path music-two "two.flac") void) (call-with-output-file (build-path music-two "two.flac") void)
(call-with-output-file outside void)) (call-with-output-file outside void))
(lambda () (λ ()
(define libraries (make-music-libraries (list music music-two))) (define libraries (make-music-libraries (list music music-two)))
(define store (open-playlist-store store-file)) (define store (open-playlist-store store-file))
(define first-id (uuid-string)) (define first-id (uuid-string))
@@ -253,4 +253,4 @@
(car (load-user-playlists store "unsafe" libraries))) (car (load-user-playlists store "unsafe" libraries)))
'()) '())
(close-playlist-store! store)) (close-playlist-store! store))
(lambda () (delete-directory/files root)))) (λ () (delete-directory/files root))))
private/users.rkt
+76 -57
View File
@@ -3,6 +3,7 @@
(require crypto (require crypto
crypto/argon2 crypto/argon2
net/private/ip net/private/ip
racket/contract
racket/list racket/list
racket/random racket/random
racket/string racket/string
@@ -58,7 +59,8 @@
; post : No module state is changed. ; post : No module state is changed.
; result : A salted Argon2id hash encoded as a string. ; result : A salted Argon2id hash encoded as a string.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-password-hash password) (define/contract (make-password-hash password)
(-> string? string?)
(unless (and (string? password) (unless (and (string? password)
(>= (string-length password) 12)) (>= (string-length password) 12))
(raise-argument-error (raise-argument-error
@@ -75,10 +77,11 @@
; post : No module state is changed. ; post : No module state is changed.
; result : #t only when both values are strings and the password matches. ; result : #t only when both values are strings and the password matches.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (password-hash-valid? password encoded) (define/contract (password-hash-valid? password encoded)
(-> any/c any/c boolean?)
(and (string? password) (and (string? password)
(string? encoded) (string? encoded)
(with-handlers ((exn:fail? (lambda (_) #f))) (with-handlers ((exn:fail? (λ (_) #f)))
(pwhash-verify password-kdf (pwhash-verify password-kdf
(string->bytes/utf-8 password) (string->bytes/utf-8 password)
encoded)))) encoded))))
@@ -101,7 +104,7 @@
(raise-argument-error 'make-auth-manager "IP address or CIDR network" value)) (raise-argument-error 'make-auth-manager "IP address or CIDR network" value))
(define address (define address
(with-handlers ((exn:fail? (with-handlers ((exn:fail?
(lambda (_) (λ (_)
(raise-argument-error (raise-argument-error
'make-auth-manager 'make-auth-manager
"IP address or CIDR network" "IP address or CIDR network"
@@ -118,7 +121,7 @@
(ip-network address prefix)) (ip-network address prefix))
(define (network-contains? network address-string) (define (network-contains? network address-string)
(with-handlers ((exn:fail? (lambda (_) #f))) (with-handlers ((exn:fail? (λ (_) #f)))
(define candidate (normal-ip-bytes address-string)) (define candidate (normal-ip-bytes address-string))
(define expected (ip-network-address network)) (define expected (ip-network-address network))
(and (= (bytes-length candidate) (bytes-length expected)) (and (= (bytes-length candidate) (bytes-length expected))
@@ -140,7 +143,7 @@
(bytes->string/utf-8 (header-value value))))) (bytes->string/utf-8 (header-value value)))))
(define (trusted-proxy? manager address) (define (trusted-proxy? manager address)
(ormap (lambda (network) (network-contains? network address)) (ormap (λ (network) (network-contains? network address))
(auth-manager-trusted-proxies manager))) (auth-manager-trusted-proxies manager)))
(define (request-address manager request) (define (request-address manager request)
@@ -160,7 +163,8 @@
; post : Manager remains unchanged. ; post : Manager remains unchanged.
; result : #t when at least one configured user can log in, otherwise #f. ; result : #t when at least one configured user can log in, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-enabled? manager) (define/contract (auth-enabled? manager)
(-> auth-manager? boolean?)
(positive? (hash-count (auth-manager-users manager)))) (positive? (hash-count (auth-manager-users manager))))
(define (request-session-token request) (define (request-session-token request)
@@ -183,7 +187,8 @@
; result : "anonymous" when authentication is disabled, the normalized ; result : "anonymous" when authentication is disabled, the normalized
; username for a valid session, or #f when login is required. ; username for a valid session, or #f when login is required.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-request-user manager request) (define/contract (auth-request-user manager request)
(-> auth-manager? request? (or/c #f string?))
(cond (cond
((not (auth-enabled? manager)) "anonymous") ((not (auth-enabled? manager)) "anonymous")
(else (else
@@ -192,7 +197,7 @@
(and token (and token
(call-with-semaphore (call-with-semaphore
(auth-manager-lock manager) (auth-manager-lock manager)
(lambda () (λ ()
(prune-sessions! manager now) (prune-sessions! manager now)
(let ((value (hash-ref (auth-manager-sessions manager) (let ((value (hash-ref (auth-manager-sessions manager)
token token
@@ -230,34 +235,39 @@
; internals: Unknown users follow the same Argon2id verification path as known ; internals: Unknown users follow the same Argon2id verification path as known
; users to reduce username-dependent timing differences. ; users to reduce username-dependent timing differences.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-login! manager request username password) (define/contract (auth-login! manager request username password)
(define address (request-address manager request)) (-> auth-manager?
(define now (current-seconds)) request?
(define normalized (string-downcase (string-trim username))) string?
(call-with-semaphore string?
(auth-manager-lock manager) (or/c #f 'rate-limited string?))
(lambda () (let ((address (request-address manager request))
(if (failure-blocked? manager address now) (now (current-seconds))
'rate-limited (normalized (string-downcase (string-trim username))))
(let* ((stored (hash-ref (auth-manager-users manager) (call-with-semaphore
normalized (auth-manager-lock manager)
#f)) (λ ()
(valid? (if (failure-blocked? manager address now)
(password-hash-valid? 'rate-limited
password (let* ((stored (hash-ref (auth-manager-users manager)
(or stored dummy-password-hash)))) normalized
(if (and stored valid?) #f))
(let ((token (valid?
(bytes->hex-string (crypto-random-bytes 32)))) (password-hash-valid?
(hash-remove! (auth-manager-failed manager) address) password
(prune-sessions! manager now) (or stored dummy-password-hash))))
(hash-set! (auth-manager-sessions manager) (if (and stored valid?)
token (let ((token
(session normalized now now)) (bytes->hex-string (crypto-random-bytes 32))))
token) (hash-remove! (auth-manager-failed manager) address)
(begin (prune-sessions! manager now)
(record-failure! manager address now) (hash-set! (auth-manager-sessions manager)
#f))))))) token
(session normalized now now))
token)
(begin
(record-failure! manager address now)
#f))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : End the browser session named by the request cookie. ; goal : End the browser session named by the request cookie.
@@ -265,12 +275,13 @@
; post : The matching server-side session is removed when it exists. ; post : The matching server-side session is removed when it exists.
; result : Void. ; result : Void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-logout! manager request) (define/contract (auth-logout! manager request)
(-> auth-manager? request? void?)
(let ((token (request-session-token request))) (let ((token (request-session-token request)))
(when token (when token
(call-with-semaphore (call-with-semaphore
(auth-manager-lock manager) (auth-manager-lock manager)
(lambda () (λ ()
(hash-remove! (auth-manager-sessions manager) token)))))) (hash-remove! (auth-manager-sessions manager) token))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -280,7 +291,8 @@
; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value whose Max-Age ; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value whose Max-Age
; equals the configured session lifetime. ; equals the configured session lifetime.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-session-cookie manager token) (define/contract (auth-session-cookie manager token)
(-> auth-manager? string? bytes?)
(string->bytes/utf-8 (string->bytes/utf-8
(format (format
"~a=~a; Path=/; Max-Age=~a; Secure; HttpOnly; SameSite=Strict" "~a=~a; Path=/; Max-Age=~a; Secure; HttpOnly; SameSite=Strict"
@@ -299,7 +311,8 @@
; this half-life threshold prevents the one-second player poll from ; this half-life threshold prevents the one-second player poll from
; returning Set-Cookie every second. ; 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) (and (auth-enabled? manager)
(let ((token (request-session-token request)) (let ((token (request-session-token request))
(now (current-seconds))) (now (current-seconds)))
@@ -308,17 +321,17 @@
(auth-manager-lock manager) (auth-manager-lock manager)
(λ () (λ ()
(prune-sessions! manager now) (prune-sessions! manager now)
(define value (let ((value
(hash-ref (auth-manager-sessions manager) token #f)) (hash-ref (auth-manager-sessions manager) token #f)))
(and value (and value
(>= (- now (session-last-cookie-renewal value)) (>= (- now (session-last-cookie-renewal value))
(max 1 (max 1
(quotient (quotient
(auth-manager-session-seconds manager) (auth-manager-session-seconds manager)
2))) 2)))
(begin (begin
(set-session-last-cookie-renewal! value now) (set-session-last-cookie-renewal! value now)
(auth-session-cookie manager token))))))))) (auth-session-cookie manager token))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Encode deletion of the browser session cookie. ; goal : Encode deletion of the browser session cookie.
@@ -326,7 +339,8 @@
; post : No module state is changed. ; post : No module state is changed.
; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value with Max-Age 0. ; result : A Secure, HttpOnly, SameSite=Strict Set-Cookie value with Max-Age 0.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (auth-expired-cookie) (define/contract (auth-expired-cookie)
(-> bytes?)
(string->bytes/utf-8 (string->bytes/utf-8
(format (format
"~a=; Path=/; Max-Age=0; Secure; HttpOnly; SameSite=Strict" "~a=; Path=/; Max-Age=0; Secure; HttpOnly; SameSite=Strict"
@@ -341,10 +355,15 @@
; empty. ; empty.
; result : A new auth-manager with normalized usernames and parsed networks. ; result : A new auth-manager with normalized usernames and parsed networks.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-auth-manager user-pairs (define/contract (make-auth-manager
#:trusted-proxies user-pairs
[trusted-proxy-values '("127.0.0.0/8" "::1/128")] #:trusted-proxies
#:session-seconds [session-seconds 604800]) [trusted-proxy-values '("127.0.0.0/8" "::1/128")]
#:session-seconds [session-seconds 604800])
(->* ((listof (cons/c string? string?)))
(#:trusted-proxies (listof string?)
#:session-seconds exact-positive-integer?)
auth-manager?)
(unless (exact-positive-integer? session-seconds) (unless (exact-positive-integer? session-seconds)
(raise-argument-error 'make-auth-manager "exact-positive-integer?" (raise-argument-error 'make-auth-manager "exact-positive-integer?"
session-seconds)) session-seconds))
public/rkt-web-player.png
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 60 KiB

scribblings/rkt-web-player.scrbl
+14 -2
View File
@@ -4,6 +4,7 @@
racket/contract racket/contract
rkt-web-player rkt-web-player
rkt-web-player/player-agent rkt-web-player/player-agent
rkt-web-player/set-user
rkt-web-player/users)) rkt-web-player/users))
@title{RKT Web Player} @title{RKT Web Player}
@@ -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. Checks a password against an encoded Argon2id hash.
} }
@defmodule[rkt-web-player/set-user]
@defproc[(set-user) void?] {
Interactively reads a username and password and writes the corresponding
Argon2id hash to the @tt{[users]} section of @filepath{rkt-web-player.ini} in
the current directory. The password must contain at least twelve characters.
}
@defmodule[rkt-web-player/player-agent] @defmodule[rkt-web-player/player-agent]
@defproc[(run-player-agent) any/c] { @defproc[(run-player-agent) any/c] {
@@ -87,8 +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 plays them with @tt{racket-audio}. Its configured display name is authoritative
and is followed by the server. Importing the module does not start the GUI; the and is followed by the server. Importing the module does not start the GUI; the
function must be called explicitly. function must be called explicitly.
The GUI and optional tray support the same ten languages based on the The GUI and its @tt{racket-tray} system tray support the same ten languages
operating-system language, with English as fallback. based on the operating-system language, with English as fallback. Closing or
minimizing the window hides it in the tray. The tray menu restores the window
or shuts down the agent; no SDL3 runtime is required.
} }
@defproc[(run-player-agent-cli [#:server-url server-url @defproc[(run-player-agent-cli [#:server-url server-url
set-user.rkt
+30 -18
View File
@@ -1,24 +1,36 @@
#lang racket/base #lang racket/base
(require "users.rkt" (require racket/class
simple-ini/class) racket/contract
simple-ini/class
"users.rkt")
(provide set-user) (provide set-user)
(define (set-user) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(displayln "Using rkt-web-player.ini as configuration file") ;; Provided functions
(newline) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(display "Give username: >")
(define user (read-line))
(display "Give password: >")
(define pwd (read-line))
(let ((hash (make-password-hash pwd)))
(define ini (new ini% [file "rkt-web-player.ini"]))
(send ini set! 'users (string->symbol user) hash)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Interactively add or replace one configured web-player user.
; pre : Standard input supplies a username and a password of at least
; twelve characters; rkt-web-player.ini is writable.
; post : The INI file's [users] section contains an Argon2id hash for the
; entered username; the clear-text password is not stored.
; result : Void after the configuration file has been updated.
; internals:
; The small utility uses simple-ini directly and intentionally owns
; no duplicate configuration representation.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (set-user)
(-> void?)
(displayln "Using rkt-web-player.ini as configuration file")
(newline)
(display "Give username: >")
(let ((user (read-line)))
(display "Give password: >")
(let* ((password (read-line))
(hash (make-password-hash password))
(ini (new ini% (file "rkt-web-player.ini"))))
(send ini set! 'users (string->symbol user) hash)
(void))))
skill/racket-skill.md
-227
View File
@@ -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>`.