#lang racket/base

(require racket/class
         racket/contract
         racket/format
         racket/gui/base
         racket/os
         racket/runtime-path
         racket/string
         racket-tray
         simple-log
         ellipsis-msg
         "player-agent-config.rkt"
         "player-agent-core.rkt"
         "player-agent-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* exit-callback)
  (-> procedure? void?)
  (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)
        (download-panel #f)
        (download-message #f)
        (download-gauge #f)
        (error-message #f)
        (name-field #f)
        (server-field #f)
        (connect-button #f)
        (quit-button #f)
        (playback-timer #f)
        (tray #f)
        (shutting-down? #f)
        )

    (define (cap200 msg)
      (substring msg 0 (min 199 (string-length msg))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ; 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 (cap200 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)))
               (download (hash-ref snapshot 'download 'null))
               (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
                      "")))))
          (when error-message
            (let ((message (hash-ref snapshot 'error 'null)))
              (send error-message show (string? message))
              (send error-message set-label
                    (if (string? message) (cap200 message) ""))))
          (when download-panel
            (send download-panel show (hash? download))
            (when (hash? download)
              (let* ((received (hash-ref download 'received))
                     (total (hash-ref download 'total))
                     (known-size? (and (number? total) (> total 0)))
                     (percent (if known-size?
                                  (min 100 (quotient (* received 100) total))
                                  0))
                     (megabytes
                      (~r (/ received 1000000.0) #:precision '(= 1))))
                (send download-gauge show known-size?)
                (send download-gauge set-value percent)
                (send download-message set-label
                      (cap200
                       (format "~a: ~a~a — ~a"
                               (tr 'downloading)
                               megabytes
                               (if known-size?
                                   (format " / ~a MB (~a%)"
                                           (~r (/ total 1000000.0)
                                               #:precision '(= 1))
                                           percent)
                                   " MB")
                               (hash-ref download 'filename)))))))
          (send playback-message
                set-label
                (cap200
                 (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 (cap200 (string-join details "  ·  ")))
          (send playback-filename
                set-label
                (cap200
                 (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 (cap200 (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)
      (exit-callback)
      )

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ; 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)))
           ;(msgs-pane (new vertical-pane% [parent panel]))
           (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 ellipsis-msg%
                 (parent playback-panel)
                 (label (tr 'no-track))
                 [ellipsis 'right] [auto-resize #t] [stretchable-width #t]
                 ))
      (set! playback-details
            (new ellipsis-msg%
                 (parent playback-panel)
                 (label "00:00:00 / --:--:--")
                 [ellipsis 'right] [auto-resize #t] [stretchable-width #t]))
      (set! playback-filename
            (new ellipsis-msg%
                 (parent playback-panel)
                 (label "—")
                 [ellipsis 'right] [auto-resize #t] [stretchable-width #t]))
      (set! download-panel
            (new vertical-panel%
                 (parent playback-panel)
                 (alignment '(left top))
                 (stretchable-height #f)))
      (set! download-message
            (new ellipsis-msg%
                 (parent download-panel)
                 (label "")
                 [ellipsis 'right] [auto-resize #t] [stretchable-width #t]))
      (set! download-gauge
            (new gauge%
                 (parent download-panel)
                 (label #f)
                 (range 100)
                 (stretchable-width #t)))
      (send download-panel show #f)
      (set! error-message
            (new ellipsis-msg%
                 (parent playback-panel)
                 (label "")
                 [ellipsis 'right] [auto-resize #t] [stretchable-width #t]))
      (send error-message show #f)
      (set! quit-button
            (new button%
                 (parent controls)
                 (label (tr 'quit))
                 (callback (λ (_button _event) (quit!)))))
      (set! connect-button
            (new button%
                 (parent controls)
                 (label (tr 'save-connect))
                 (callback (λ (_button _event) (reconnect!)))))
      (set! status-message
            (new ellipsis-msg%
                 (parent controls)
                 (label (tr 'connecting))
                 [ellipsis 'right] [auto-resize #t] [stretchable-width #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 (cap200 (tr 'reconnect)))

    (void)))


(define (run-player-agent-gui)
  (let ((quit-semaphore (make-semaphore 0)))

    (run-player-agent-gui*
     (λ ()
       (semaphore-post quit-semaphore)))

    (yield quit-semaphore)

    (void)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module library.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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)))