607 lines
20 KiB
Racket
607 lines
20 KiB
Racket
#lang racket/base
|
|
|
|
(require file/sha1
|
|
json
|
|
net/url
|
|
racket-audio
|
|
racket/class
|
|
racket/file
|
|
racket/format
|
|
racket/gui/base
|
|
racket/os
|
|
racket/path
|
|
racket/port
|
|
racket/random
|
|
racket/string
|
|
simple-ini
|
|
simple-log)
|
|
|
|
(provide run-player-agent-gui)
|
|
|
|
|
|
(define (input-field label init-val panel)
|
|
(let ((tf (new text-field%
|
|
[parent panel]
|
|
[label label]
|
|
[init-value init-val]))
|
|
)
|
|
(let ((editor (send tf get-editor)))
|
|
(send editor set-padding 0 2 0 2))
|
|
|
|
tf))
|
|
|
|
|
|
(sl-def-log player-agent)
|
|
|
|
(define config-file
|
|
(get-ini-file 'rkt-web-player-agent))
|
|
|
|
(define log-file
|
|
(build-path (find-system-path 'pref-dir)
|
|
"rkt-web-player-agent.log"))
|
|
|
|
(define (fresh-app-id)
|
|
(bytes->hex-string (crypto-random-bytes 32)))
|
|
|
|
(define (valid-app-id? value)
|
|
(and (string? value)
|
|
(regexp-match? #px"^[0-9a-fA-F]{64}$" value)))
|
|
|
|
(define config
|
|
(file->ini config-file))
|
|
|
|
(define app-id
|
|
(let ((configured (ini-get config 'agent 'app-id #f)))
|
|
(if (valid-app-id? configured)
|
|
(string-downcase configured)
|
|
(fresh-app-id))))
|
|
|
|
(define server-url
|
|
(ini-get config 'server 'url "http://127.0.0.1:8080"))
|
|
|
|
(define assigned-name
|
|
(ini-get config 'agent 'name
|
|
(format "~a playback" (gethostname))))
|
|
|
|
(define (save-config!)
|
|
(ini-set! config 'agent 'app-id app-id)
|
|
(ini-set! config 'agent 'name assigned-name)
|
|
(ini-set! config 'server 'url server-url)
|
|
(ini->file config config-file #:private? #t))
|
|
|
|
(save-config!)
|
|
|
|
(define (base-url value)
|
|
(string->url
|
|
(regexp-replace #px"/+$" (string-trim value) "")))
|
|
|
|
(define (endpoint-url base path)
|
|
(combine-url/relative (base-url base) path))
|
|
|
|
(define (post-json base path data)
|
|
(let ((input
|
|
(post-pure-port
|
|
(endpoint-url base path)
|
|
(jsexpr->bytes data)
|
|
(list "Content-Type: application/json"
|
|
"Cache-Control: no-store"))))
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(let ((response (read-json input)))
|
|
(when (and (hash? response)
|
|
(string? (hash-ref response 'error #f)))
|
|
(error 'player-agent
|
|
(hash-ref response 'error)))
|
|
response))
|
|
(λ ()
|
|
(close-input-port input)))))
|
|
|
|
(define (normal-state state)
|
|
(cond
|
|
((eq? state 'transitioning) "starting")
|
|
((eq? state 'initialized) "stopped")
|
|
((eq? state 'no-media) "stopped")
|
|
(else (symbol->string state))))
|
|
|
|
(define (safe-delete-file file)
|
|
(when (and file (file-exists? file))
|
|
(with-handlers ((exn:fail?
|
|
(λ (exception)
|
|
(warn-player-agent
|
|
"Could not remove temporary media file ~a: ~a"
|
|
file
|
|
(exn-message exception)))))
|
|
(delete-file file))))
|
|
|
|
(define (run-player-agent-gui)
|
|
(sl-log-to-file log-file)
|
|
|
|
(define state-lock (make-semaphore 1))
|
|
(define worker #f)
|
|
(define command-worker #f)
|
|
(define executing-command-id 0)
|
|
(define running? #f)
|
|
(define audio #f)
|
|
(define temporary-media #f)
|
|
(define current-media-key #f)
|
|
(define cached-media (make-hash))
|
|
(define current-track #f)
|
|
(define acknowledged-command 0)
|
|
(define ended-counter 0)
|
|
(define eof-pending? #f)
|
|
(define logical-volume 50)
|
|
(define agent-state
|
|
(hasheq 'state "stopped"
|
|
'position 0
|
|
'duration 'null
|
|
'rate 'null
|
|
'channels 'null
|
|
'bits 'null
|
|
'format ""
|
|
'volume logical-volume
|
|
'error 'null))
|
|
|
|
(define (format-time value)
|
|
(let* ((seconds
|
|
(if (and (number? value) (>= value 0))
|
|
(inexact->exact (floor value))
|
|
0))
|
|
(hours (quotient seconds 3600))
|
|
(minutes (quotient (remainder seconds 3600) 60))
|
|
(remaining (remainder seconds 60)))
|
|
(format "~a:~a:~a"
|
|
(~r hours #:min-width 2 #:pad-string "0")
|
|
(~r minutes #:min-width 2 #:pad-string "0")
|
|
(~r remaining #:min-width 2 #:pad-string "0"))))
|
|
|
|
(define (with-agent-state proc)
|
|
(call-with-semaphore state-lock proc))
|
|
|
|
(define (state-value value fallback)
|
|
(if (eq? value #f) fallback value))
|
|
|
|
(define (update-from-audio! state full-state)
|
|
(with-agent-state
|
|
(λ ()
|
|
(define normalized (normal-state state))
|
|
(set! agent-state
|
|
(hasheq
|
|
'state normalized
|
|
'position
|
|
(state-value (hash-ref full-state 'at-second #f) 0)
|
|
'duration
|
|
(state-value (hash-ref full-state 'duration #f) 'null)
|
|
'rate
|
|
(state-value (hash-ref full-state 'rate #f) 'null)
|
|
'channels
|
|
(state-value (hash-ref full-state 'channels #f) 'null)
|
|
'bits
|
|
(state-value (hash-ref full-state 'bits #f) 'null)
|
|
'format
|
|
(let ((decoder (hash-ref full-state 'decoder #f)))
|
|
(if decoder (format "~a" decoder) ""))
|
|
'volume logical-volume
|
|
'error 'null))
|
|
;; racket-audio reports decoder EOF before its output buffer has
|
|
;; drained. Advance only when playback itself has actually stopped.
|
|
(when (and eof-pending? (string=? normalized "stopped"))
|
|
(set! eof-pending? #f)
|
|
(set! ended-counter (+ ended-counter 1))))))
|
|
|
|
(define (set-agent-error! message)
|
|
(with-agent-state
|
|
(λ ()
|
|
(set! agent-state
|
|
(hash-set agent-state 'error message)))))
|
|
|
|
(define (clear-agent-error!)
|
|
(with-agent-state
|
|
(λ ()
|
|
(set! agent-state
|
|
(hash-set agent-state 'error 'null)))))
|
|
|
|
(define (state-snapshot)
|
|
(with-agent-state
|
|
(λ () agent-state)))
|
|
|
|
(define (ensure-audio!)
|
|
(unless audio
|
|
(set! audio
|
|
(make-audio-player
|
|
(λ (_handle state full-state)
|
|
(update-from-audio! state full-state))
|
|
(λ (_handle)
|
|
(with-agent-state
|
|
(λ ()
|
|
(set! eof-pending? #t))))))
|
|
(audio-ao-buf-ms! audio 500)
|
|
(audio-buf-seconds! audio 4 10)
|
|
(let ((scaled (/ logical-volume 100.0)))
|
|
(audio-volume! audio (* 100.0 scaled scaled))))
|
|
audio)
|
|
|
|
(define (download-media! token filename)
|
|
(let* ((extension
|
|
(or (path-get-extension (string->path filename)) #""))
|
|
(template
|
|
(string-append "rkt-player-agent-~a"
|
|
(bytes->string/utf-8 extension)))
|
|
(target (make-temporary-file template))
|
|
(path
|
|
(format "/api/agent/media/~a/~a" app-id token))
|
|
(input (get-pure-port (endpoint-url server-url path))))
|
|
(with-handlers
|
|
((exn:fail?
|
|
(λ (exception)
|
|
(close-input-port input)
|
|
(safe-delete-file target)
|
|
(raise exception))))
|
|
(call-with-output-file
|
|
target
|
|
(λ (output)
|
|
(copy-port input output))
|
|
#:exists 'truncate/replace)
|
|
(close-input-port input)
|
|
target)))
|
|
|
|
(define (command-cache-key data)
|
|
(hash-ref data 'cacheKey (hash-ref data 'mediaToken)))
|
|
|
|
(define (ensure-media-cached! data)
|
|
(let* ((key (command-cache-key data))
|
|
(found (hash-ref cached-media key #f)))
|
|
(if (and found (file-exists? found))
|
|
found
|
|
(let ((downloaded
|
|
(download-media!
|
|
(hash-ref data 'mediaToken)
|
|
(hash-ref data 'filename "track"))))
|
|
(hash-set! cached-media key downloaded)
|
|
downloaded))))
|
|
|
|
(define (discard-unused-media! keep-key)
|
|
(for ((entry (in-list (hash->list cached-media))))
|
|
(unless (equal? (car entry) keep-key)
|
|
(safe-delete-file (cdr entry))
|
|
(hash-remove! cached-media (car entry)))))
|
|
|
|
(define (execute-command! command)
|
|
(let* ((action (hash-ref command 'action ""))
|
|
(data (hash-ref command 'data (hasheq))))
|
|
(info-player-agent "Executing command ~a" action)
|
|
(cond
|
|
((string=? action "play")
|
|
(with-agent-state (λ () (set! eof-pending? #f)))
|
|
(set! current-track data)
|
|
(with-agent-state
|
|
(λ ()
|
|
(set! agent-state
|
|
(hash-set
|
|
(hash-set agent-state 'state "starting")
|
|
'error
|
|
'null))))
|
|
(let* ((next-key (command-cache-key data))
|
|
(next-media (ensure-media-cached! data)))
|
|
;; audio-play! already interrupts and closes the previous decoder.
|
|
;; Calling audio-stop! first can delete a finished FLAC decoder a
|
|
;; second time in racket-audio.
|
|
(audio-play! (ensure-audio!) next-media)
|
|
(set! current-media-key next-key)
|
|
(set! temporary-media next-media)
|
|
(discard-unused-media! next-key)))
|
|
((string=? action "prefetch")
|
|
(let ((key (command-cache-key data)))
|
|
(ensure-media-cached! data)
|
|
;; Retain the playing file and the one prepared for playback.
|
|
(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 (λ () (set! eof-pending? #f)))
|
|
(when audio (audio-stop! audio)))
|
|
((string=? action "seek")
|
|
(audio-seek! (ensure-audio!)
|
|
(hash-ref data 'percentage 0)))
|
|
((string=? action "volume")
|
|
(set! logical-volume
|
|
(min 100 (max 0 (hash-ref data 'value 50))))
|
|
(let ((scaled (/ logical-volume 100.0)))
|
|
(audio-volume! (ensure-audio!)
|
|
(* 100.0 scaled scaled)))
|
|
(with-agent-state
|
|
(λ ()
|
|
(set! agent-state
|
|
(hash-set agent-state
|
|
'volume
|
|
logical-volume)))))
|
|
(else
|
|
(error 'player-agent "unknown command: ~a" action)))))
|
|
|
|
(define frame #f)
|
|
(define status-message #f)
|
|
(define playback-message #f)
|
|
(define playback-details #f)
|
|
(define playback-filename #f)
|
|
(define name-field #f)
|
|
(define server-field #f)
|
|
(define connect-button #f)
|
|
(define shutting-down? #f)
|
|
(define playback-timer #f)
|
|
|
|
(define (show-status! message)
|
|
(queue-callback
|
|
(λ ()
|
|
(when status-message
|
|
(send status-message set-label message)))
|
|
#f))
|
|
|
|
(define (show-name! name)
|
|
(queue-callback
|
|
(λ ()
|
|
(when name-field
|
|
(send name-field set-value name)))
|
|
#f))
|
|
|
|
(define (refresh-playback-status!)
|
|
(when (and playback-message playback-details playback-filename)
|
|
(let* ((snapshot (state-snapshot))
|
|
(state (hash-ref snapshot 'state "stopped"))
|
|
(title
|
|
(and current-track
|
|
(hash-ref current-track 'title #f)))
|
|
(artist
|
|
(and current-track
|
|
(hash-ref current-track 'artist #f)))
|
|
(filename
|
|
(and current-track
|
|
(hash-ref current-track 'filename #f)))
|
|
(track-number
|
|
(and current-track
|
|
(hash-ref current-track 'trackNumber #f)))
|
|
(track-label
|
|
(cond
|
|
((and artist (not (string=? artist "")) title)
|
|
(format "~a — ~a" artist title))
|
|
(title title)
|
|
(else "Geen track geselecteerd")))
|
|
(prefix
|
|
(cond
|
|
((string=? state "playing") "Speelt")
|
|
((string=? state "paused") "Gepauzeerd")
|
|
((string=? state "starting") "Laden")
|
|
((string=? state "stopped") "Gestopt")
|
|
(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
|
|
(if (= channels 1) "kanaal" "kanalen"))
|
|
"")
|
|
(if (and (string? format-name)
|
|
(not (string=? format-name "")))
|
|
format-name
|
|
"")))))
|
|
(send playback-message
|
|
set-label
|
|
(if current-track
|
|
(format "~a~a: ~a"
|
|
prefix
|
|
(if (number? track-number)
|
|
(format " #~a" track-number)
|
|
"")
|
|
track-label)
|
|
"Er wordt niets afgespeeld"))
|
|
(send playback-details set-label (string-join details " · "))
|
|
(send playback-filename
|
|
set-label
|
|
(if (and (string? filename) (not (string=? filename "")))
|
|
filename
|
|
"—")))))
|
|
|
|
(define (poll-loop)
|
|
(with-handlers
|
|
((exn:fail?
|
|
(λ (exception)
|
|
(warn-player-agent "Connection cycle failed: ~a"
|
|
(exn-message exception))
|
|
(set-agent-error! (exn-message exception))
|
|
(show-status! (format "Niet verbonden: ~a"
|
|
(exn-message exception)))
|
|
(when running?
|
|
(sleep 3)
|
|
(poll-loop)))))
|
|
(let ((registration
|
|
(post-json
|
|
server-url
|
|
"/api/agent/register"
|
|
(hasheq 'appId app-id
|
|
'name assigned-name))))
|
|
(show-name! assigned-name)
|
|
(clear-agent-error!)
|
|
(show-status! "Verbonden")
|
|
(info-player-agent "Registered at ~a as ~a"
|
|
server-url assigned-name)
|
|
(let loop ()
|
|
(when running?
|
|
(let* ((response
|
|
(post-json
|
|
server-url
|
|
"/api/agent/poll"
|
|
(hasheq 'appId app-id
|
|
'name assigned-name
|
|
'ack acknowledged-command
|
|
'endedCounter ended-counter
|
|
'state (state-snapshot))))
|
|
(command
|
|
(hash-ref response 'command 'null)))
|
|
(when (and (hash? command)
|
|
(> (hash-ref command 'id 0)
|
|
acknowledged-command)
|
|
(not (= (hash-ref command 'id 0)
|
|
executing-command-id)))
|
|
(set! executing-command-id
|
|
(hash-ref command 'id))
|
|
(set!
|
|
command-worker
|
|
(thread
|
|
(λ ()
|
|
(with-handlers
|
|
((exn:fail?
|
|
(λ (exception)
|
|
(warn-player-agent "Command failed: ~a"
|
|
(exn-message exception))
|
|
(set-agent-error!
|
|
(exn-message exception)))))
|
|
(clear-agent-error!)
|
|
(execute-command! command))
|
|
(set! acknowledged-command
|
|
(hash-ref command 'id))
|
|
(set! executing-command-id 0)
|
|
(set! command-worker #f)))))
|
|
(sleep 1)
|
|
(loop)))))))
|
|
|
|
(define (start-worker!)
|
|
(set! running? #t)
|
|
(set! worker (thread poll-loop))
|
|
(send connect-button set-label "Opnieuw verbinden"))
|
|
|
|
(define (stop-worker!)
|
|
(set! running? #f)
|
|
(when (and worker (not (thread-dead? worker)))
|
|
(kill-thread worker))
|
|
(when (and command-worker
|
|
(not (thread-dead? command-worker)))
|
|
(kill-thread command-worker))
|
|
(set! worker #f)
|
|
(set! command-worker #f)
|
|
(set! executing-command-id 0))
|
|
|
|
(define (reconnect!)
|
|
(stop-worker!)
|
|
(set! server-url (string-trim (send server-field get-value)))
|
|
(let ((new-name (string-trim (send name-field get-value))))
|
|
(set! assigned-name
|
|
(if (string=? new-name "")
|
|
(format "~a playback" (gethostname))
|
|
new-name)))
|
|
(save-config!)
|
|
(show-status! "Verbinden…")
|
|
(start-worker!))
|
|
|
|
(define (shutdown!)
|
|
(unless shutting-down?
|
|
(set! shutting-down? #t)
|
|
(stop-worker!)
|
|
(when playback-timer
|
|
(send playback-timer stop))
|
|
(when audio
|
|
(with-handlers ((exn:fail? void))
|
|
(audio-quit! audio))
|
|
(set! audio #f))
|
|
(for ((path (in-hash-values cached-media)))
|
|
(safe-delete-file path))
|
|
(hash-clear! cached-media)))
|
|
|
|
(define agent-frame%
|
|
(class frame%
|
|
(super-new)
|
|
(define/augment (on-close)
|
|
(shutdown!)
|
|
(inner (void) on-close))))
|
|
|
|
(set! frame
|
|
(new agent-frame%
|
|
(label "RKT Web Player Agent")
|
|
(width 560)
|
|
(height 310)))
|
|
(define panel
|
|
(new vertical-panel%
|
|
(parent frame)
|
|
(alignment '(left top))
|
|
;(border 12)
|
|
;(spacing 8)
|
|
))
|
|
(set! server-field (input-field "RKT Web Player server" server-url panel))
|
|
(set! name-field (input-field "Naam" assigned-name panel))
|
|
(define id-field (input-field "Applicatie-ID" app-id panel))
|
|
|
|
;; Lock just the editor instead of disabling the complete widget. Windows
|
|
;; renders disabled native controls in grey, which made the label and ID look
|
|
;; as though their glyphs were damaged.
|
|
(send (send id-field get-editor) lock #t)
|
|
|
|
(define playback-panel
|
|
(new group-box-panel%
|
|
(parent panel)
|
|
(label "Afspelen")
|
|
(alignment '(left top))
|
|
(stretchable-height #f)))
|
|
(set! playback-message
|
|
(new message%
|
|
(parent playback-panel)
|
|
(label "Er wordt niets afgespeeld")
|
|
(auto-resize #t)))
|
|
(set! playback-details
|
|
(new message%
|
|
(parent playback-panel)
|
|
(label "00:00:00 / --:--:--")
|
|
(auto-resize #t)))
|
|
(set! playback-filename
|
|
(new message%
|
|
(parent playback-panel)
|
|
(label "—")
|
|
(auto-resize #t)))
|
|
|
|
(define controls
|
|
(new horizontal-panel%
|
|
(parent panel)
|
|
(alignment '(left center))))
|
|
(set! connect-button
|
|
(new button%
|
|
(parent controls)
|
|
(label "Opslaan en verbinden")
|
|
(callback (λ (_button _event)
|
|
(reconnect!)))))
|
|
(set! status-message
|
|
(new message%
|
|
(parent controls)
|
|
(label "Verbinden…")
|
|
(auto-resize #t)))
|
|
|
|
(set! playback-timer
|
|
(new timer%
|
|
(notify-callback refresh-playback-status!)
|
|
(interval 500)))
|
|
(refresh-playback-status!)
|
|
|
|
(send frame show #t)
|
|
(start-worker!)
|
|
frame)
|