Better GUI

private/player-agent-gui.rkt

@@ -6,6 +6,7 @@
          racket-audio
          racket/class
          racket/file
+         racket/format
          racket/gui/base
          racket/os
          racket/path
@@ -13,7 +14,8 @@
          racket/random
          racket/string
          simple-ini
-         simple-log)
+         simple-log
+         "windows-tray.rkt")
 
 (provide run-player-agent-gui)
 
@@ -49,9 +51,13 @@
   (ini-get config 'agent 'name
            (format "~a playback" (gethostname))))
 
+(define tray-enabled?
+  (ini-get config 'agent 'system-tray #t))
+
 (define (save-config!)
   (ini-set! config 'agent 'app-id app-id)
   (ini-set! config 'agent 'name assigned-name)
+  (ini-set! config 'agent 'system-tray tray-enabled?)
   (ini-set! config 'server 'url server-url)
   (ini->file config config-file #:private? #t))
 
@@ -110,6 +116,7 @@
   (define running? #f)
   (define audio #f)
   (define temporary-media #f)
+  (define current-track #f)
   (define acknowledged-command 0)
   (define ended-counter 0)
   (define logical-volume 50)
@@ -124,6 +131,19 @@
             '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))
 
@@ -214,6 +234,14 @@
       (info-player-agent "Executing command ~a" action)
       (cond
         ((string=? action "play")
+         (set! current-track data)
+         (with-agent-state
+          (λ ()
+            (set! agent-state
+                  (hash-set
+                   (hash-set agent-state 'state "starting")
+                   'error
+                   'null))))
          (let ((next-media
                 (download-media!
                  (hash-ref data 'mediaToken)
@@ -248,9 +276,15 @@
 
   (define frame #f)
   (define status-message #f)
+  (define playback-message #f)
+  (define playback-details #f)
   (define name-field #f)
   (define server-field #f)
   (define connect-button #f)
+  (define tray-checkbox #f)
+  (define tray-stop #f)
+  (define shutting-down? #f)
+  (define playback-timer #f)
 
   (define (show-status! message)
     (queue-callback
@@ -266,6 +300,55 @@
          (send name-field set-value name)))
      #f))
 
+  (define (refresh-playback-status!)
+    (when (and playback-message playback-details)
+      (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)))
+             (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))
+             (details
+              (filter
+               (λ (value) (not (string=? value "")))
+               (list
+                (format "~a / ~a"
+                        (format-time position)
+                        (if (number? duration)
+                            (format-time duration)
+                            "--:--:--"))
+                (if (string=? format-name "") format-name
+                    (string-upcase format-name))
+                (if (number? rate)
+                    (format "~a kHz" (~r (/ rate 1000.0)
+                                         #:precision '(= 1)))
+                    "")))))
+        (send playback-message
+              set-label
+              (if current-track
+                  (format "~a: ~a" prefix track-label)
+                  "Er wordt niets afgespeeld"))
+        (send playback-details set-label (string-join details "  ·  ")))))
+
   (define (poll-loop)
     (with-handlers
         ((exn:fail?
@@ -357,22 +440,63 @@
     (show-status! "Verbinden…")
     (start-worker!))
 
+  (define (stop-tray!)
+    (when tray-stop
+      (tray-stop)
+      (set! tray-stop #f)))
+
+  (define (shutdown!)
+    (unless shutting-down?
+      (set! shutting-down? #t)
+      (stop-worker!)
+      (stop-tray!)
+      (when playback-timer
+        (send playback-timer stop))
+      (when audio
+        (with-handlers ((exn:fail? void))
+          (audio-quit! audio))
+        (set! audio #f))
+      (safe-delete-file temporary-media)))
+
+  (define (ensure-tray!)
+    (cond
+      ((and tray-enabled? (not tray-stop))
+       (set!
+        tray-stop
+        (start-windows-tray!
+         (λ ()
+           (queue-callback
+            (λ ()
+              (send frame show #t)
+              (send frame focus))
+            #f))
+         (λ ()
+           (queue-callback
+            (λ ()
+              (shutdown!)
+              (send frame show #f))
+            #f))))
+       (when (and tray-enabled? (not tray-stop))
+         (set! tray-enabled? #f)
+         (save-config!)
+         (when tray-checkbox
+           (send tray-checkbox set-value #f))))
+      ((not tray-enabled?)
+       (stop-tray!))))
+
   (define agent-frame%
     (class frame%
       (super-new)
       (define/augment (on-close)
-        (stop-worker!)
-        (when audio
-          (with-handlers ((exn:fail? void))
-            (audio-quit! audio)))
-        (safe-delete-file temporary-media)
+        (unless (and tray-enabled? tray-stop)
+          (shutdown!))
         (inner (void) on-close))))
 
   (set! frame
         (new agent-frame%
              (label "RKT Web Player Agent")
              (width 560)
-             (height 230)))
+             (height 310)))
   (define panel
     (new vertical-panel%
          (parent frame)
@@ -394,7 +518,28 @@
          (parent panel)
          (label "Applicatie-ID")
          (init-value app-id)))
-  (send id-field enable #f)
+  ;; 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)))
+
   (define controls
     (new horizontal-panel%
          (parent panel)
@@ -411,6 +556,25 @@
              (label "Verbinden…")
              (auto-resize #t)))
 
+  (set! tray-checkbox
+        (new check-box%
+             (parent panel)
+             (label "In het systeemvak actief blijven na sluiten")
+             (value (and tray-enabled? (windows-tray-available?)))
+             (enabled (windows-tray-available?))
+             (callback
+              (λ (box _event)
+                (set! tray-enabled? (send box get-value))
+                (save-config!)
+                (ensure-tray!)))))
+
+  (set! playback-timer
+        (new timer%
+             (notify-callback refresh-playback-status!)
+             (interval 500)))
+  (refresh-playback-status!)
+
   (send frame show #t)
+  (ensure-tray!)
   (start-worker!)
   frame)