414 lines
16 KiB
Racket
414 lines
16 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class
|
|
racket/contract
|
|
racket/format
|
|
racket/gui/base
|
|
racket/os
|
|
racket/runtime-path
|
|
racket/string
|
|
racket-tray
|
|
simple-log
|
|
"player-agent-config.rkt"
|
|
"player-agent-core.rkt"
|
|
"translate.rkt")
|
|
|
|
(provide run-player-agent-gui)
|
|
|
|
(sl-def-log player-agent-gui)
|
|
|
|
(define log-file
|
|
(build-path (find-system-path 'pref-dir)
|
|
"rkt-web-player-agent.log"))
|
|
|
|
(define-runtime-path tray-icon
|
|
"../public/rkt-web-player.png")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create a labelled text field with compact editor padding.
|
|
; pre : label and init-value are strings; panel accepts GUI children.
|
|
; post : A text field has been added to panel.
|
|
; result : The newly created text-field% object.
|
|
; internals:
|
|
; Padding is set on the editor because it renders consistently on
|
|
; the supported desktop platforms.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (input-field label init-value panel)
|
|
(let ((field
|
|
(new text-field%
|
|
(parent panel)
|
|
(label label)
|
|
(init-value init-value))))
|
|
(send (send field get-editor) set-padding 0 2 0 2)
|
|
field))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Format a playback position as hours, minutes and seconds.
|
|
; pre : value is any Racket value.
|
|
; post : No state is changed.
|
|
; result : A zero-padded HH:MM:SS string; invalid values are treated as zero.
|
|
; internals:
|
|
; Fractional seconds are deliberately rounded down so the displayed
|
|
; position never runs ahead of the audio runtime.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (format-time value)
|
|
(let* ((seconds
|
|
(if (and (number? value) (>= value 0))
|
|
(inexact->exact (floor value))
|
|
0))
|
|
(hours (quotient seconds 3600))
|
|
(minutes (quotient (remainder seconds 3600) 60))
|
|
(remaining (remainder seconds 60)))
|
|
(format "~a:~a:~a"
|
|
(~r hours #:min-width 2 #:pad-string "0")
|
|
(~r minutes #:min-width 2 #:pad-string "0")
|
|
(~r remaining #:min-width 2 #:pad-string "0"))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Start the graphical polling playback agent.
|
|
; pre : A graphical desktop and the platform support required by
|
|
; racket-tray are available.
|
|
; post : The agent runtime is started, its frame and tray icon are visible,
|
|
; and closing or minimizing the frame hides it in the system tray.
|
|
; result : The live frame% object belonging to the playback agent.
|
|
; internals:
|
|
; The GUI owns only widgets, configuration and lifecycle callbacks.
|
|
; Playback and polling remain in player-agent-core.rkt. racket-tray
|
|
; owns native tray resources and the portable minimize watcher.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define/contract (run-player-agent-gui)
|
|
(-> (is-a?/c frame%))
|
|
(sl-log-to-file log-file)
|
|
(let ((config (load-player-agent-config))
|
|
(frame #f)
|
|
(runtime #f)
|
|
(status-message #f)
|
|
(playback-message #f)
|
|
(playback-details #f)
|
|
(playback-filename #f)
|
|
(name-field #f)
|
|
(server-field #f)
|
|
(connect-button #f)
|
|
(playback-timer #f)
|
|
(tray #f)
|
|
(shutting-down? #f))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Queue a status-label update in the GUI eventspace.
|
|
; pre : message is a string supplied by the agent runtime.
|
|
; post : The status widget shows message when it has been created.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; Runtime callbacks can originate outside the GUI eventspace, so
|
|
; widget access is always forwarded with queue-callback.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (show-status! message)
|
|
(queue-callback
|
|
(λ ()
|
|
(when status-message
|
|
(send status-message set-label message)))
|
|
#f))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Show a playback-agent authorization failure.
|
|
; pre : message is a string supplied by the agent runtime.
|
|
; post : A modal error dialog is queued for the agent frame.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; The callback is eventspace-safe for the same reason as the
|
|
; status callback above.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (show-denial! message)
|
|
(queue-callback
|
|
(λ ()
|
|
(message-box (tr 'denied-title)
|
|
message
|
|
frame
|
|
'(ok stop)))
|
|
#f))
|
|
|
|
(set! runtime
|
|
(make-player-agent-runtime
|
|
(player-agent-config-server-url config)
|
|
(player-agent-config-name config)
|
|
(player-agent-config-app-id config)
|
|
#:status-callback show-status!
|
|
#:denied-callback show-denial!))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Refresh the visible playback summary from the runtime cache.
|
|
; pre : runtime exists; the widgets may still be uninitialized.
|
|
; post : Initialized playback widgets reflect one coherent cached
|
|
; snapshot and its current track.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; This procedure never performs network I/O. The timer reads only
|
|
; the cache maintained by player-agent-core.rkt.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (refresh-playback-status!)
|
|
(when (and playback-message playback-details playback-filename)
|
|
(let* ((snapshot ((player-agent-runtime-snapshot runtime)))
|
|
(track ((player-agent-runtime-current-track runtime)))
|
|
(state (hash-ref snapshot 'state "stopped"))
|
|
(title (and track (hash-ref track 'title #f)))
|
|
(artist (and track (hash-ref track 'artist #f)))
|
|
(filename (and track (hash-ref track 'filename #f)))
|
|
(track-number (and track (hash-ref track 'trackNumber #f)))
|
|
(track-label
|
|
(cond
|
|
((and artist (not (string=? artist "")) title)
|
|
(format "~a — ~a" artist title))
|
|
(title title)
|
|
(else (tr 'no-track-selected))))
|
|
(prefix
|
|
(cond
|
|
((string=? state "playing") (tr 'playing))
|
|
((string=? state "paused") (tr 'paused))
|
|
((string=? state "starting") (tr 'loading))
|
|
((string=? state "stopped") (tr 'stopped))
|
|
(else state)))
|
|
(position (hash-ref snapshot 'position 0))
|
|
(duration (hash-ref snapshot 'duration 'null))
|
|
(format-name (hash-ref snapshot 'format ""))
|
|
(rate (hash-ref snapshot 'rate 'null))
|
|
(bits (hash-ref snapshot 'bits 'null))
|
|
(channels (hash-ref snapshot 'channels 'null))
|
|
(details
|
|
(filter
|
|
(λ (value) (not (string=? value "")))
|
|
(list
|
|
(format "~a / ~a"
|
|
(format-time position)
|
|
(if (number? duration)
|
|
(format-time duration)
|
|
"--:--:--"))
|
|
(if (number? bits) (format "~a bit" bits) "")
|
|
(if (number? rate)
|
|
(format "~a kHz"
|
|
(~r (/ rate 1000.0) #:precision '(= 1)))
|
|
"")
|
|
(if (number? channels)
|
|
(format "~a ~a"
|
|
channels
|
|
(tr (if (= channels 1) 'channel 'channels)))
|
|
"")
|
|
(if (and (string? format-name)
|
|
(not (string=? format-name "")))
|
|
format-name
|
|
"")))))
|
|
(send playback-message
|
|
set-label
|
|
(if track
|
|
(format "~a~a: ~a"
|
|
prefix
|
|
(if (number? track-number)
|
|
(format " #~a" track-number)
|
|
"")
|
|
track-label)
|
|
(tr 'no-track)))
|
|
(send playback-details set-label (string-join details " · "))
|
|
(send playback-filename
|
|
set-label
|
|
(if (and (string? filename)
|
|
(not (string=? filename "")))
|
|
filename
|
|
"—")))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Persist edited connection settings and reconnect the runtime.
|
|
; pre : The name, server and connect widgets have been initialized.
|
|
; post : config and the INI file contain normalized values; the runtime
|
|
; reconnects with them and the button becomes a reconnect button.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; An empty name receives the same hostname-based default used by
|
|
; initial configuration loading.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (reconnect!)
|
|
(let* ((next-server (string-trim (send server-field get-value)))
|
|
(entered-name (string-trim (send name-field get-value)))
|
|
(next-name
|
|
(if (string=? entered-name "")
|
|
(format "~a playback" (gethostname))
|
|
entered-name)))
|
|
(set! config
|
|
(struct-copy player-agent-config config
|
|
(server-url next-server)
|
|
(name next-name)))
|
|
(save-player-agent-config! config)
|
|
(send name-field set-value next-name)
|
|
((player-agent-runtime-reconnect! runtime) next-server next-name)
|
|
(send connect-button set-label (tr 'reconnect))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Release resources owned by the GUI agent exactly once.
|
|
; pre : runtime has been created; timer and tray may be #f.
|
|
; post : Playback polling, audio, the GUI timer and native tray resources
|
|
; have stopped; subsequent calls do nothing.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; The guard makes this procedure safe from both the window close
|
|
; path and the tray Exit action.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (shutdown!)
|
|
(unless shutting-down?
|
|
(set! shutting-down? #t)
|
|
(when playback-timer
|
|
(send playback-timer stop))
|
|
((player-agent-runtime-shutdown! runtime))
|
|
(when tray
|
|
(tray-close tray)
|
|
(set! tray #f))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Terminate the graphical agent from its tray menu.
|
|
; pre : frame and runtime have been initialized.
|
|
; post : Resources are released and the frame is hidden.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; racket-tray invokes actions in the frame eventspace, so no
|
|
; additional GUI callback queue is needed here.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (quit!)
|
|
(shutdown!)
|
|
(send frame show #f))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Restore the agent frame from the tray.
|
|
; pre : frame has been initialized and has not been destroyed.
|
|
; post : frame is visible and no longer iconized.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; De-iconizing is needed because racket-tray hides minimized
|
|
; frames instead of changing their iconized state.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (show-window!)
|
|
(send frame show #t)
|
|
(when (send frame is-iconized?)
|
|
(send frame iconize #f)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Dispatch a symbolic racket-tray action.
|
|
; pre : action is installed in the tray menu below.
|
|
; post : 'open restores the frame; 'exit shuts down the agent.
|
|
; result : Unspecified.
|
|
; internals:
|
|
; One callback handles both direct tray activation and menu
|
|
; selection on every platform.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (tray-action! action)
|
|
(case action
|
|
((open) (show-window!))
|
|
((exit) (quit!))))
|
|
|
|
(let* ((agent-frame%
|
|
(class frame%
|
|
(super-new)
|
|
(define/augment (on-close)
|
|
(if tray
|
|
(send this show #f)
|
|
(begin
|
|
(shutdown!)
|
|
(inner (void) on-close))))))
|
|
(new-frame
|
|
(new agent-frame%
|
|
(label (tr 'app-title))
|
|
(width 560)
|
|
(height 310))))
|
|
(set! frame new-frame))
|
|
|
|
(let* ((panel
|
|
(new vertical-panel%
|
|
(parent frame)
|
|
(alignment '(left top))))
|
|
(server
|
|
(input-field (tr 'server)
|
|
(player-agent-config-server-url config)
|
|
panel))
|
|
(name
|
|
(input-field (tr 'name)
|
|
(player-agent-config-name config)
|
|
panel))
|
|
(id-field
|
|
(input-field (tr 'application-id)
|
|
(player-agent-config-app-id config)
|
|
panel))
|
|
(playback-panel
|
|
(new group-box-panel%
|
|
(parent panel)
|
|
(label (tr 'playback))
|
|
(alignment '(left top))
|
|
(stretchable-height #f)))
|
|
(controls
|
|
(new horizontal-panel%
|
|
(parent panel)
|
|
(alignment '(left center)))))
|
|
(set! server-field server)
|
|
(set! name-field name)
|
|
;; Lock the editor, not the native widget. Disabled Windows controls
|
|
;; render their label and text poorly on some display configurations.
|
|
(send (send id-field get-editor) lock #t)
|
|
(set! playback-message
|
|
(new message%
|
|
(parent playback-panel)
|
|
(label (tr 'no-track))
|
|
(auto-resize #t)))
|
|
(set! playback-details
|
|
(new message%
|
|
(parent playback-panel)
|
|
(label "00:00:00 / --:--:--")
|
|
(auto-resize #t)))
|
|
(set! playback-filename
|
|
(new message%
|
|
(parent playback-panel)
|
|
(label "—")
|
|
(auto-resize #t)))
|
|
(set! connect-button
|
|
(new button%
|
|
(parent controls)
|
|
(label (tr 'save-connect))
|
|
(callback (λ (_button _event) (reconnect!)))))
|
|
(set! status-message
|
|
(new message%
|
|
(parent controls)
|
|
(label (tr 'connecting))
|
|
(auto-resize #t))))
|
|
|
|
(set! playback-timer
|
|
(new timer%
|
|
(notify-callback refresh-playback-status!)
|
|
(interval 500)))
|
|
(refresh-playback-status!)
|
|
|
|
(set! tray
|
|
(mk-tray frame
|
|
tray-icon
|
|
(list tray-action! 'open)
|
|
#:hide-on-minimize? #t))
|
|
(tray-set-menu!
|
|
tray
|
|
(list
|
|
(list 'open (tr 'tray-open))
|
|
'separator
|
|
(list 'exit (tr 'quit))))
|
|
|
|
(send frame show #t)
|
|
((player-agent-runtime-start! runtime))
|
|
(send connect-button set-label (tr 'reconnect))
|
|
frame))
|
|
|
|
(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)))
|