Better GUI

README.md

@@ -92,6 +92,14 @@ in. De naam wordt in dezelfde agent-GUI ingesteld. Na registratie verschijnt
 de agent met die naam als uitvoer van type `AGENT`; de server volgt latere
 naamswijzigingen bij registratie en polling.
 
+Onder **Afspelen** toont de agent de huidige track, afspeeltoestand, verstreken
+en totale tijd, decoderformaat en samplefrequentie. Op Windows kan de agent via
+de optie onderaan actief blijven in het systeemvak wanneer het venster wordt
+gesloten. Dubbelklik op het pictogram om het venster terug te halen; via het
+contextmenu kan de agent volledig worden afgesloten. Hiervoor gebruikt de
+agent de standaard Windows Forms-notificatiezone via de aanwezige Windows
+PowerShell. Op andere platforms blijft de optie uitgeschakeld.
+
 De eerste implementatie downloadt een geselecteerde track volledig naar een
 tijdelijk bestand voordat `racket-audio` de weergave start. Daardoor is de
 implementatie klein en zijn geen gedeelde mappen nodig, maar het starten van

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)

private/player.rkt

@@ -367,7 +367,11 @@
                   'filename
                   (path->string
                    (or (file-name-from-path (track-file item))
-                       (track-file item)))))))
+                       (track-file item)))
+                  'title (track-title item)
+                  'artist (track-artist item)
+                  'album (track-album item)
+                  'duration (or (track-duration item) 'null)))))
       (else
        (dlna-player-play! backend (track-file item))))
     (clear-error! value)))

private/windows-tray.rkt

@@ -0,0 +1,97 @@
+#lang racket/base
+
+(require racket/port
+         racket/system)
+
+(provide windows-tray-available?
+         start-windows-tray!)
+
+(define (windows-tray-available?)
+  (and (eq? (system-type 'os) 'windows)
+       (find-executable-path "powershell.exe")
+       #t))
+
+(define tray-script
+  #<<POWERSHELL
+[Console]::OutputEncoding = [System.Text.Encoding]::UTF8
+Add-Type -AssemblyName System.Windows.Forms
+Add-Type -AssemblyName System.Drawing
+
+$tray = New-Object System.Windows.Forms.NotifyIcon
+$tray.Icon = [System.Drawing.SystemIcons]::Application
+$tray.Text = "RKT Web Player Agent"
+$tray.Visible = $true
+
+$menu = New-Object System.Windows.Forms.ContextMenuStrip
+$open = $menu.Items.Add("Open RKT Web Player Agent")
+$quit = $menu.Items.Add("Exit")
+$tray.ContextMenuStrip = $menu
+
+$send = {
+  param([string]$message)
+  [Console]::Out.WriteLine($message)
+  [Console]::Out.Flush()
+}
+
+$open.add_Click({ & $send "open" })
+$tray.add_DoubleClick({ & $send "open" })
+$quit.add_Click({
+  & $send "quit"
+  $tray.Visible = $false
+  [System.Windows.Forms.Application]::Exit()
+})
+
+[System.Windows.Forms.Application]::Run()
+$tray.Visible = $false
+$tray.Dispose()
+POWERSHELL
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Add a Windows notification-area icon with open and quit actions.
+; pre    : Called on Windows with PowerShell and a GUI eventspace available.
+; post   : Callbacks are delivered from a reader thread; the stop thunk removes
+;          the helper process and its icon.
+; result : A stop thunk, or #f when the platform has no supported tray helper.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (start-windows-tray! on-open on-quit)
+  (cond
+    ((not (windows-tray-available?)) #f)
+    (else
+     (let-values (((process output input error-output)
+                   (subprocess
+                    #f #f #f
+                    (find-executable-path "powershell.exe")
+                    "-NoLogo"
+                    "-NoProfile"
+                    "-NonInteractive"
+                    "-WindowStyle"
+                    "Hidden"
+                    "-STA"
+                    "-Command"
+                    tray-script)))
+       (close-output-port input)
+       (define stopped? #f)
+       (define reader
+         (thread
+          (λ ()
+            (let loop ()
+              (let ((line (read-line output 'any)))
+                (unless (eof-object? line)
+                  (cond
+                    ((string=? line "open") (on-open))
+                    ((string=? line "quit") (on-quit)))
+                  (loop)))))))
+       (thread
+        (λ ()
+          ;; Drain diagnostics so the helper cannot block on a full pipe.
+          (copy-port error-output (open-output-nowhere))))
+       (λ ()
+         (unless stopped?
+           (set! stopped? #t)
+           (when (and reader (not (thread-dead? reader)))
+             (kill-thread reader))
+           (close-input-port output)
+           (close-input-port error-output)
+           (when (eq? (subprocess-status process) 'running)
+             (subprocess-kill process #t))))))))