#lang racket/base

(require racket-audio
         racket-audio-dlna
         file/sha1
         racket/list
         racket/path
         racket/random
         racket/string
         racket-sonos
         racket-upnp
         simple-log
         "library.rkt")

(provide make-player
         player-state->jsexpr
         player-command!
         player-discover!
         player-agent-register!
         player-agent-poll!
         player-agent-media
         player-close!)

(sl-def-log web-player)

(struct renderer
  (id [name #:mutable] kind device)
  #:transparent)

(struct playback-agent
  (app-id
   [name #:mutable]
   [last-seen #:mutable]
   [reported-state #:mutable]
   [commands #:mutable]
   [next-command-id #:mutable]
   [media-token #:mutable]
   [media-file #:mutable]
   [ended-counter #:mutable])
  #:transparent)

(struct playlist-tab
  (id [name #:mutable] [tracks #:mutable])
  #:transparent)

(struct player
  (libraries
   [agents #:mutable]
   [current-library-id #:mutable]
   [browser-path #:mutable]
   [browser-entries #:mutable]
   [tracks #:mutable]
   [tabs #:mutable]
   [current-tab-index #:mutable]
   [renderers #:mutable]
   [selected-id #:mutable]
   [backend #:mutable]
   [backend-kind #:mutable]
   [current-index #:mutable]
   [state #:mutable]
   [position #:mutable]
   [duration #:mutable]
   [rate #:mutable]
   [channels #:mutable]
   [bits #:mutable]
   [decoder #:mutable]
   [volume #:mutable]
   [repeat #:mutable]
   [error #:mutable]
   [discovering? #:mutable]
   [closed? #:mutable]
   state-lock
   command-lock
   dlna-port)
  #:transparent)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal state / functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (with-state-lock value proc)
  (call-with-semaphore (player-state-lock value) proc))

(define (renderer-by-id value id)
  (findf (λ (item)
           (string=? (renderer-id item) id))
         (player-renderers value)))

(define (agent-renderer-id app-id)
  (string-append "agent:" app-id))

(define (agent-by-id value app-id)
  (findf (λ (agent)
           (string=? (playback-agent-app-id agent) app-id))
         (player-agents value)))

(define (agent-renderer value agent)
  (renderer-by-id value
                  (agent-renderer-id
                   (playback-agent-app-id agent))))

(define (valid-agent-id? value)
  (and (string? value)
       (regexp-match? #px"^[0-9a-fA-F]{64}$" value)))

(define (fresh-media-token)
  (bytes->hex-string (crypto-random-bytes 32)))

(define (enqueue-agent-command! value agent action [data (hasheq)])
  (with-state-lock
   value
   (λ ()
     (let* ((id (playback-agent-next-command-id agent))
            (command (hasheq 'id id
                             'action action
                             'data data)))
       (set-playback-agent-next-command-id! agent (+ id 1))
       (set-playback-agent-commands!
        agent
        (append (playback-agent-commands agent)
                (list command)))
       command))))

(define agent-heartbeat-timeout-seconds 10)

(define (prune-stale-agents! value)
  (with-state-lock
   value
   (λ ()
     (let* ((cutoff (- (current-seconds)
                       agent-heartbeat-timeout-seconds))
            (stale
             (filter (λ (agent)
                       (< (playback-agent-last-seen agent) cutoff))
                     (player-agents value)))
            (stale-ids
             (map (λ (agent)
                    (agent-renderer-id
                     (playback-agent-app-id agent)))
                  stale)))
       (unless (null? stale)
         (set-player-agents!
          value
          (filter (λ (agent)
                    (not (member (agent-renderer-id
                                  (playback-agent-app-id agent))
                                 stale-ids)))
                  (player-agents value)))
         (set-player-renderers!
          value
          (filter (λ (item)
                    (not (member (renderer-id item) stale-ids)))
                  (player-renderers value)))
         (when (member (player-selected-id value) stale-ids)
           (set-player-selected-id! value "local")
           (set-player-backend! value #f)
           (set-player-backend-kind! value #f)
           (set-player-state! value 'stopped)
           (set-player-position! value 0)
           (set-player-duration! value #f)
           (reset-audio-info! value)))))))

(define (library-by-id value id)
  (findf (λ (library)
           (string=? (music-library-id library) id))
         (player-libraries value)))

(define (current-library value)
  (and (player-current-library-id value)
       (library-by-id value
                      (player-current-library-id value))))

(define (current-tab value)
  (list-ref (player-tabs value)
            (player-current-tab-index value)))

(define (save-current-tab! value)
  (set-playlist-tab-tracks!
   (current-tab value)
   (player-tracks value)))

(define (normalize-state state)
  (cond
    ((eq? state 'playing) 'playing)
    ((eq? state 'paused) 'paused)
    ((eq? state 'transitioning) 'starting)
    ((eq? state 'initialized) 'stopped)
    ((eq? state 'no-media) 'stopped)
    (else state)))

(define (set-error! value message)
  (with-state-lock
   value
   (λ ()
     (set-player-error! value message))))

(define (clear-error! value)
  (set-error! value #f))

(define (reset-audio-info! value)
  (set-player-rate! value #f)
  (set-player-channels! value #f)
  (set-player-bits! value #f)
  (set-player-decoder! value #f))

(define (local-state-callback value handle state full-state)
  (with-state-lock
   value
   (λ ()
     (when (eq? handle (player-backend value))
       (set-player-state! value (normalize-state state))
       (set-player-position!
        value
        (or (hash-ref full-state 'at-second #f) 0))
       (set-player-duration!
        value
        (hash-ref full-state 'duration #f))
       (set-player-rate! value
                         (hash-ref full-state 'rate #f))
       (set-player-channels! value
                             (hash-ref full-state 'channels #f))
       (set-player-bits! value
                         (hash-ref full-state 'bits #f))
       (set-player-decoder! value
                            (hash-ref full-state 'decoder #f))))))

(define (local-end-callback value handle)
  (when (eq? handle (player-backend value))
    (with-handlers
        ((exn:fail?
          (λ (exception)
            (set-error! value (exn-message exception)))))
      (player-command! value "next" (hasheq)))))

(define (make-local-backend value)
  (let ((backend
         (make-audio-player
          (λ (handle state full-state)
            (local-state-callback value handle state full-state))
          (λ (handle)
            (local-end-callback value handle)))))
    (audio-ao-buf-ms! backend 500)
    (audio-buf-seconds! backend 4 10)
    (let ((logical-volume
           (/ (player-volume value) 100.0)))
      (audio-volume!
       backend
       (* 100.0 logical-volume logical-volume)))
    backend))

(define (make-network-backend value device)
  (make-dlna-player device
                    #:port (player-dlna-port value)
                    #:path "/rkt-web-player/"))

(define (ensure-backend! value)
  (if (player-backend value)
      (player-backend value)
      (let* ((selected
              (renderer-by-id value
                              (player-selected-id value)))
             (kind (and selected (renderer-kind selected)))
             (backend
              (cond
                ((eq? kind 'local)
                 (make-local-backend value))
                ((or (eq? kind 'upnp)
                     (eq? kind 'sonos))
                 (make-network-backend
                  value
                  (renderer-device selected)))
                ((eq? kind 'agent)
                 (renderer-device selected))
                (else
                 (raise-arguments-error
                  'player-command!
                  "selected renderer is unavailable"
                  "renderer" (player-selected-id value))))))
        (with-state-lock
         value
         (λ ()
           (set-player-backend! value backend)
           (set-player-backend-kind! value kind)))
        backend)))

(define (close-backend! value)
  (let ((backend (player-backend value))
        (kind (player-backend-kind value)))
    (when backend
      (with-handlers
          ((exn:fail?
            (λ (exception)
              (warn-web-player
               "Could not close ~a player: ~a"
               kind
               (exn-message exception)))))
        (cond
          ((eq? kind 'local)
           (audio-quit! backend))
          ((eq? kind 'agent)
           (enqueue-agent-command! value backend "stop"))
          (else
           (dlna-player-close! backend)))))
    (with-state-lock
     value
     (λ ()
       (set-player-backend! value #f)
       (set-player-backend-kind! value #f)
       (set-player-state! value 'stopped)
       (set-player-position! value 0)
       (set-player-duration! value #f)
       (reset-audio-info! value)))))

(define (stop-playback! value)
  (when (player-backend value)
    (cond
      ((eq? (player-backend-kind value) 'local)
       (audio-stop! (player-backend value)))
      ((eq? (player-backend-kind value) 'agent)
       (enqueue-agent-command! value
                               (player-backend value)
                               "stop"))
      (else
       (dlna-player-stop! (player-backend value)))))
  (with-state-lock
   value
   (λ ()
     (set-player-state! value 'stopped)
     (set-player-position! value 0)
     (reset-audio-info! value))))

(define (valid-track-index? value index)
  (and (exact-nonnegative-integer? index)
       (< index (length (player-tracks value)))))

(define (play-index! value index)
  (unless (valid-track-index? value index)
    (raise-arguments-error
     'player-command!
     "track index is outside the playlist"
     "index" index))
  (let* ((item (list-ref (player-tracks value) index))
         (backend (ensure-backend! value))
         (kind (player-backend-kind value)))
    (with-state-lock
     value
     (λ ()
       (set-player-current-index! value index)
       (set-player-state! value 'starting)
       (set-player-position! value 0)
       (set-player-duration! value (track-duration item))))
    (cond
      ((eq? kind 'local)
       (audio-play! backend (track-file item)))
      ((eq? kind 'agent)
       (let ((token (fresh-media-token)))
         (with-state-lock
          value
          (λ ()
            (set-playback-agent-media-token! backend token)
            (set-playback-agent-media-file! backend (track-file item))))
         (enqueue-agent-command!
          value
          backend
          "play"
          (hasheq 'mediaToken token
                  'filename
                  (path->string
                   (or (file-name-from-path (track-file item))
                       (track-file item)))))))
      (else
       (dlna-player-play! backend (track-file item))))
    (clear-error! value)))

(define (next-index value direction)
  (let ((count (length (player-tracks value)))
        (current (player-current-index value))
        (repeat (player-repeat value)))
    (cond
      ((zero? count) #f)
      ((eq? repeat 'one) current)
      ((eq? current #f)
       (if (positive? direction) 0 (- count 1)))
      (else
       (let ((candidate (+ current direction)))
         (cond
           ((and (>= candidate 0) (< candidate count)) candidate)
           ((eq? repeat 'all)
            (if (positive? direction) 0 (- count 1)))
           (else #f)))))))

(define (refresh-network-state! value)
  (when (and (player-backend value)
             (not (eq? (player-backend-kind value) 'local)))
    (with-handlers
        ((exn:fail?
          (λ (exception)
            (set-error! value (exn-message exception)))))
      (if (eq? (player-backend-kind value) 'agent)
          (let ((reported
                 (playback-agent-reported-state
                  (player-backend value))))
            ;; Keep the server's optimistic command state visible until the
            ;; agent acknowledges all queued work. Its report in the poll that
            ;; receives a command still describes the state before execution.
            (when (and (hash? reported)
                       (null? (playback-agent-commands
                               (player-backend value))))
              (with-state-lock
               value
               (λ ()
                 (let ((state (hash-ref reported 'state #f)))
                   (when (string? state)
                     (set-player-state!
                      value
                      (normalize-state (string->symbol state)))))
                 (set-player-position!
                  value
                  (or (json-number reported 'position #f) 0))
                 (set-player-duration!
                  value
                  (json-number reported 'duration #f))
                 (set-player-rate!
                  value
                  (json-number reported 'rate #f))
                 (set-player-channels!
                  value
                  (json-number reported 'channels #f))
                 (set-player-bits!
                  value
                  (json-number reported 'bits #f))
                 (let ((decoder (json-string reported 'format #f)))
                   (set-player-decoder!
                    value
                    (and decoder (string->symbol decoder))))
                 (let ((volume (json-number reported 'volume #f)))
                   (when volume
                     (set-player-volume! value volume)))
                 (let ((error (json-string reported 'error #f)))
                   (set-player-error! value error))))))
          (let* ((info (dlna-player-info (player-backend value)))
                 (track-info (dlna-info-track info)))
        (with-state-lock
         value
         (λ ()
           (set-player-state!
            value
            (normalize-state (dlna-info-state info)))
           (set-player-position!
            value
            (or (dlna-info-position info) 0))
           (set-player-duration!
            value
            (dlna-info-duration info))
           (set-player-rate!
            value
            (and track-info
                 (dlna-track-info-sample-rate track-info)))
           (set-player-channels!
            value
            (and track-info
                 (dlna-track-info-channels track-info)))
           (set-player-bits! value #f)
           (set-player-decoder! value 'dlna)
           (when (number? (dlna-info-volume info))
             (set-player-volume! value
                                 (dlna-info-volume info))))))))))

(define (entry-by-index value index)
  (and (exact-nonnegative-integer? index)
       (< index (length (player-browser-entries value)))
       (list-ref (player-browser-entries value) index)))

(define (refresh-browser! value library relative-path)
  (let ((entries (browse-library library relative-path)))
    (with-state-lock
     value
     (λ ()
       (set-player-current-library-id!
        value
        (music-library-id library))
       (set-player-browser-path! value relative-path)
       (set-player-browser-entries! value entries)))))

(define (selected-entry-tracks value index)
  (let ((entry (entry-by-index value index))
        (library (current-library value)))
    (unless entry
      (raise-arguments-error
       'player-command!
       "library entry does not exist"
       "index" index))
    (unless library
      (raise-arguments-error
       'player-command!
       "no music library is selected"))
    (browser-entry->tracks library entry)))

(define (same-track? first second)
  (equal? (normal-case-path (track-file first))
          (normal-case-path (track-file second))))

(define (append-tracks! value tracks)
  (let ((combined
         (foldl
          (λ (item result)
            (if (findf (λ (existing)
                         (same-track? item existing))
                       result)
                result
                (append result (list item))))
          (player-tracks value)
          tracks)))
    (with-state-lock
     value
     (λ ()
       (set-player-tracks! value combined)
       (save-current-tab! value)))))

(define (replace-tracks! value tracks)
  (stop-playback! value)
  (with-state-lock
   value
   (λ ()
     (set-player-tracks! value tracks)
     (set-player-current-index! value #f)
     (save-current-tab! value))))

(define (drop-track! value index)
  (unless (valid-track-index? value index)
    (raise-arguments-error
     'player-command!
     "track index is outside the playlist"
     "index" index))
  (when (equal? index (player-current-index value))
    (stop-playback! value))
  (with-state-lock
   value
   (λ ()
     (set-player-tracks!
      value
      (append (take (player-tracks value) index)
              (drop (player-tracks value) (+ index 1))))
     (cond
       ((equal? index (player-current-index value))
        (set-player-current-index! value #f))
       ((and (player-current-index value)
             (< index (player-current-index value)))
        (set-player-current-index!
         value
         (- (player-current-index value) 1))))
     (save-current-tab! value))))

(define (move-track! value from-index to-index)
  (unless (and (valid-track-index? value from-index)
               (valid-track-index? value to-index))
    (raise-arguments-error
     'player-command!
     "track move indexes are outside the playlist"
     "from" from-index
     "to" to-index))
  (unless (= from-index to-index)
    (with-state-lock
     value
     (λ ()
       (let* ((tracks (player-tracks value))
              (item (list-ref tracks from-index))
              (without
               (append (take tracks from-index)
                       (drop tracks (+ from-index 1))))
              (moved
               (append (take without to-index)
                       (list item)
                       (drop without to-index)))
              (current (player-current-index value)))
         (set-player-tracks! value moved)
         (when current
           (cond
             ((= current from-index)
              (set-player-current-index! value to-index))
             ((and (< from-index current)
                   (<= current to-index))
              (set-player-current-index! value (- current 1)))
             ((and (<= to-index current)
                   (< current from-index))
              (set-player-current-index! value (+ current 1)))))
         (save-current-tab! value))))))

(define (select-tab! value index)
  (unless (and (exact-nonnegative-integer? index)
               (< index (length (player-tabs value))))
    (raise-arguments-error
     'player-command!
     "playlist tab does not exist"
     "index" index))
  (unless (= index (player-current-tab-index value))
    (stop-playback! value)
    (with-state-lock
     value
     (λ ()
       (save-current-tab! value)
       (set-player-current-tab-index! value index)
       (set-player-tracks!
        value
        (playlist-tab-tracks (current-tab value)))
       (set-player-current-index! value #f)))))

(define (add-tab! value)
  (with-state-lock
   value
   (λ ()
     (save-current-tab! value)
     (let* ((tabs (player-tabs value))
            (number (+ (length tabs) 1))
            (tab
             (playlist-tab
              (format "tab-~a-~a"
                      (current-milliseconds)
                      (random 10000))
              (format "Playlist ~a" number)
              '())))
       (set-player-tabs! value (append tabs (list tab)))
       (set-player-current-tab-index! value (length tabs))
       (set-player-tracks! value '())
       (set-player-current-index! value #f)))))

(define (rename-tab! value index name)
  (unless (and (exact-nonnegative-integer? index)
               (< index (length (player-tabs value))))
    (raise-arguments-error
     'player-command!
     "playlist tab does not exist"
     "index" index))
  (let ((trimmed (string-trim name)))
    (when (string=? trimmed "")
      (raise-arguments-error
       'player-command!
       "playlist name cannot be empty"))
    (with-state-lock
     value
     (λ ()
       (set-playlist-tab-name!
        (list-ref (player-tabs value) index)
        trimmed)))))

(define (delete-tab! value index)
  (when (= (length (player-tabs value)) 1)
    (raise-arguments-error
     'player-command!
     "the last playlist tab cannot be removed"))
  (unless (and (exact-nonnegative-integer? index)
               (< index (length (player-tabs value))))
    (raise-arguments-error
     'player-command!
     "playlist tab does not exist"
     "index" index))
  (stop-playback! value)
  (with-state-lock
   value
   (λ ()
     (save-current-tab! value)
     (let* ((tabs
             (append (take (player-tabs value) index)
                     (drop (player-tabs value) (+ index 1))))
            (new-index
             (min (player-current-tab-index value)
                  (- (length tabs) 1))))
       (set-player-tabs! value tabs)
       (set-player-current-tab-index! value new-index)
       (set-player-tracks!
        value
        (playlist-tab-tracks (list-ref tabs new-index)))
       (set-player-current-index! value #f)))))

(define (track->jsexpr item index)
  (hasheq 'index index
          'title (track-title item)
          'artist (track-artist item)
          'album (track-album item)
          'duration (or (track-duration item) 'null)
          'mimeType (track-mime-type item)
          'source (path->string
                   (or (file-name-from-path (track-file item))
                       (track-file item)))))

(define (renderer->jsexpr item)
  (hasheq 'id (renderer-id item)
          'name (renderer-name item)
          'kind (symbol->string (renderer-kind item))))

(define (library->jsexpr library)
  (hasheq 'id (music-library-id library)
          'name (music-library-name library)))

(define (browser-entry->jsexpr entry index)
  (hasheq 'index index
          'name (browser-entry-name entry)
          'kind (symbol->string (browser-entry-kind entry))))

(define (tab->jsexpr tab index)
  (hasheq 'index index
          'id (playlist-tab-id tab)
          'name (playlist-tab-name tab)
          'count (length (playlist-tab-tracks tab))))

(define (normal-device-id device)
  (let ((id (upnp-device-udn device)))
    (and id
         (let ((match
                (regexp-match
                 #px"(?i:RINCON_[0-9A-F]+)"
                 id)))
           (if match
               (string-upcase (car match))
               (regexp-replace #px"(?i:^uuid:)" id ""))))))

(define (sonos-member? device member-ids)
  (let ((id (normal-device-id device)))
    (and id
         (ormap (λ (member-id)
                  (string-ci=? id member-id))
                member-ids))))

(define (discover-renderers)
  (let* ((devices (query-upnp-devices 'all))
         (media-renderers (filter media-renderer? devices))
         (groups
          (with-handlers
              ((exn:fail?
                (λ (exception)
                  (warn-web-player
                   "Could not read Sonos topology: ~a"
                   (exn-message exception))
                  '())))
            (sonos-groups devices)))
         (member-ids
          (append-map sonos-group-member-ids groups))
         (upnp-renderers
          (for/list ((device (in-list media-renderers))
                     #:unless (sonos-member? device member-ids))
            (renderer
             (format "upnp:~a"
                     (or (upnp-device-udn device)
                         (media-renderer-address device)))
             (if (sonos-device? device)
                 (sonos-device-name device)
                 (media-renderer-name device))
             'upnp
             device)))
         (sonos-renderers
          (for/list ((group (in-list groups)))
            (renderer
             (format "sonos:~a" (sonos-group-id group))
             (sonos-group-name group)
             'sonos
             (sonos-group-renderer group)))))
    (sort (append upnp-renderers sonos-renderers)
          string-ci<?
          #:key renderer-name)))

(define (json-number data key [default #f])
  (let ((value (hash-ref data key default)))
    (if (number? value) value default)))

(define (json-string data key [default #f])
  (let ((value (hash-ref data key default)))
    (if (string? value) value default)))

(define (perform-library-command! value command data)
  (let ((index (json-number data 'index #f)))
    (cond
      ((string=? command "library")
       (let* ((id (json-string data 'id #f))
              (library (and id (library-by-id value id))))
         (unless library
           (raise-arguments-error
            'player-command!
            "music library does not exist"
            "id" id))
         (refresh-browser! value library '())))
      ((string=? command "browse")
       (let ((entry (entry-by-index value index)))
         (unless (and entry
                      (eq? (browser-entry-kind entry) 'container))
           (raise-arguments-error
            'player-command!
            "library entry is not a directory"
            "index" index))
         (refresh-browser!
          value
          (current-library value)
          (browser-entry-relative-path entry))))
      ((string=? command "up")
       (unless (null? (player-browser-path value))
         (refresh-browser!
          value
          (current-library value)
          (drop-right (player-browser-path value) 1))))
      ((string=? command "item-play")
       (let ((tracks (selected-entry-tracks value index)))
         (when (null? tracks)
           (raise-arguments-error
            'player-command!
            "selected item contains no supported audio"))
         (replace-tracks! value tracks)
         (play-index! value 0)))
      ((string=? command "item-add")
       (append-tracks!
        value
        (selected-entry-tracks value index))))))

(define (perform-playlist-command! value command data)
  (let ((index (json-number data 'index #f)))
    (cond
      ((string=? command "track-remove")
       (drop-track! value index))
      ((string=? command "track-move")
       (move-track! value
                    (json-number data 'from #f)
                    (json-number data 'to #f)))
      ((string=? command "playlist-clear")
       (replace-tracks! value '()))
      ((string=? command "tab-add")
       (stop-playback! value)
       (add-tab! value))
      ((string=? command "tab-select")
       (select-tab! value index))
      ((string=? command "tab-rename")
       (rename-tab! value index
                    (or (json-string data 'name #f) "")))
      ((string=? command "tab-delete")
       (delete-tab! value index)))))

(define (perform-command! value command data)
  (cond
    ((member command '("library" "browse" "up"
                       "item-play" "item-add"))
     (perform-library-command! value command data))
    ((member command '("track-remove" "track-move"
                       "playlist-clear" "tab-add"
                       "tab-select" "tab-rename"
                       "tab-delete"))
     (perform-playlist-command! value command data))
    ((string=? command "play")
     (play-index!
      value
      (or (json-number data 'index #f)
          (player-current-index value)
          0)))
    ((string=? command "pause")
     (let ((backend (ensure-backend! value)))
       (cond
         ((eq? (player-backend-kind value) 'local)
          (audio-pause! backend #t))
         ((eq? (player-backend-kind value) 'agent)
          (enqueue-agent-command! value backend "pause"))
         (else
          (dlna-player-pause! backend)))))
    ((string=? command "resume")
     (let ((backend (ensure-backend! value)))
       (cond
         ((eq? (player-backend-kind value) 'local)
          (audio-pause! backend #f))
         ((eq? (player-backend-kind value) 'agent)
          (enqueue-agent-command! value backend "resume"))
         (else
          (dlna-player-resume! backend)))))
    ((string=? command "stop")
     (stop-playback! value))
    ((string=? command "next")
     (let ((index (next-index value 1)))
       (if index
           (play-index! value index)
           (stop-playback! value))))
    ((string=? command "previous")
     (let ((index (next-index value -1)))
       (when index
         (play-index! value index))))
    ((string=? command "seek")
     (let ((percentage (json-number data 'percentage #f)))
       (unless percentage
         (raise-arguments-error
          'player-command!
          "seek requires a numeric percentage"))
       (let ((backend (ensure-backend! value)))
         (cond
           ((eq? (player-backend-kind value) 'local)
            (audio-seek! backend percentage))
           ((eq? (player-backend-kind value) 'agent)
            (enqueue-agent-command!
             value backend "seek"
             (hasheq 'percentage percentage)))
           (else
            (dlna-player-seek-percentage! backend percentage))))))
    ((string=? command "volume")
     (let ((percentage (json-number data 'value #f)))
       (unless percentage
         (raise-arguments-error
          'player-command!
          "volume requires a numeric value"))
       (let* ((clamped (min 100 (max 0 percentage)))
              (backend (ensure-backend! value)))
         (cond
           ((eq? (player-backend-kind value) 'local)
            (let ((logical-volume (/ clamped 100.0)))
              (audio-volume!
               backend
               (* 100.0 logical-volume logical-volume))))
           ((eq? (player-backend-kind value) 'agent)
            (enqueue-agent-command!
             value backend "volume"
             (hasheq 'value clamped)))
           (else
            (dlna-player-volume! backend clamped)))
         (with-state-lock
          value
          (λ ()
            (set-player-volume! value clamped))))))
    ((string=? command "repeat")
     (let* ((name (json-string data 'mode "off"))
            (mode (string->symbol name)))
       (unless (member mode '(off all one))
         (raise-arguments-error
          'player-command!
          "repeat mode must be off, all, or one"
          "mode" name))
       (with-state-lock
        value
        (λ ()
          (set-player-repeat! value mode)))))
    ((string=? command "renderer")
     (let* ((id (json-string data 'id #f))
            (selected (and id (renderer-by-id value id))))
       (unless selected
         (raise-arguments-error
          'player-command!
          "renderer does not exist"
          "id" id))
       (unless (string=? id (player-selected-id value))
         (close-backend! value)
         (with-state-lock
          value
          (λ ()
           (set-player-selected-id! value id))))))
    (else
     (raise-arguments-error
      'player-command!
      "unknown player command"
      "command" command))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create a player for lazily browsed music libraries.
; pre    : Libraries is a list of music-library values; DLNA port is positive.
; post   : Only the selected root directory has been listed; no backend exists.
; result : A player that initially selects local playback.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-player libraries #:dlna-port [dlna-port 8734])
  (let* ((library (and (pair? libraries) (car libraries)))
         (browser-entries
          (if library
              (browse-library library '())
              '()))
         (tab (playlist-tab "default" "Default" '())))
    (player libraries
            '()
            (and library (music-library-id library))
            '()
            browser-entries
            '()
            (list tab)
            0
            (list (renderer "local" "Server audio output" 'local #f))
            "local"
            #f
            #f
            #f
            'stopped
            0
            #f
            #f
            #f
            #f
            #f
            50
            'off
            #f
            #f
            #f
            (make-semaphore 1)
            (make-semaphore 1)
            dlna-port)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Return the complete browser-visible player state.
; pre    : Value was created with make-player.
; post   : Cached DLNA playback information has been incorporated.
; result : A JSON-compatible hash.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (player-state->jsexpr value)
  (prune-stale-agents! value)
  (refresh-network-state! value)
  (with-state-lock
   value
   (λ ()
     (let ((current
            (and (player-current-index value)
                 (valid-track-index?
                  value
                  (player-current-index value))
                 (list-ref (player-tracks value)
                           (player-current-index value)))))
       (hasheq
        'libraries (map library->jsexpr
                        (player-libraries value))
        'libraryId (or (player-current-library-id value) 'null)
        'browser
        (hasheq
         'path (map path->string (player-browser-path value))
         'canGoUp (not (null? (player-browser-path value)))
         'entries
         (for/list ((entry (in-list (player-browser-entries value)))
                    (index (in-naturals)))
           (browser-entry->jsexpr entry index)))
        'tabs
        (for/list ((tab (in-list (player-tabs value)))
                   (index (in-naturals)))
          (tab->jsexpr tab index))
        'currentTab (player-current-tab-index value)
        'tracks
        (for/list ((item (in-list (player-tracks value)))
                   (index (in-naturals)))
          (track->jsexpr item index))
        'renderers (map renderer->jsexpr
                        (player-renderers value))
        'rendererId (player-selected-id value)
        'currentIndex (or (player-current-index value) 'null)
        'state (symbol->string (player-state value))
        'position (player-position value)
        'duration (or (player-duration value) 'null)
        'rate (or (player-rate value) 'null)
        'channels (or (player-channels value) 'null)
        'bits (or (player-bits value) 'null)
        'format (if (player-decoder value)
                    (format "~a" (player-decoder value))
                    "")
        'source (if current
                    (path->string
                     (or (file-name-from-path (track-file current))
                         (track-file current)))
                    "")
        'volume (player-volume value)
        'repeat (symbol->string (player-repeat value))
        'discovering (player-discovering? value)
        'error (or (player-error value) 'null))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Execute one browser player command.
; pre    : Command is a string and data is a JSON object hash.
; post   : The command has completed or a concrete exception is raised.
; result : The updated JSON-compatible player state.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (player-command! value command data)
  (call-with-semaphore
   (player-command-lock value)
   (λ ()
     (when (player-closed? value)
       (raise-arguments-error
        'player-command!
        "player has been closed"))
     (with-handlers
         ((exn:fail?
           (λ (exception)
             (set-error! value (exn-message exception))
             (raise exception))))
       (perform-command! value command data))
     (player-state->jsexpr value))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Discover UPnP renderers and logical Sonos groups asynchronously.
; pre    : Value was created with make-player.
; post   : The renderer list is updated when discovery finishes.
; result : #t when discovery started, #f when it was already running.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (player-discover! value)
  (let ((can-start?
         (with-state-lock
          value
          (λ ()
            (if (player-discovering? value)
                #f
                (begin
                  (set-player-discovering?! value #t)
                  #t))))))
    (when can-start?
      (thread
       (λ ()
         (with-handlers
             ((exn:fail?
               (λ (exception)
                 (set-error! value (exn-message exception)))))
           (let ((found (discover-renderers)))
             (with-state-lock
              value
              (λ ()
                (set-player-renderers!
                 value
                 (append
                  (list (renderer "local"
                                  "Server audio output"
                                  'local
                                  #f))
                  found
                  (filter (λ (item)
                            (eq? (renderer-kind item) 'agent))
                          (player-renderers value))))
                (set-player-error! value #f)))))
         (with-state-lock
          value
          (λ ()
            (set-player-discovering?! value #f))))))
    can-start?))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Register or refresh one polling playback agent.
; pre    : Data contains a 256-bit hexadecimal application id.
; post   : The agent is available as a renderer under its advertised name.
; result : Agent configuration for the polling client.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (player-agent-register! value data)
  (let* ((app-id (json-string data 'appId #f))
         (suggested-name
          (string-trim
           (or (json-string data 'name #f)
               "RKT playback agent"))))
    (unless (valid-agent-id? app-id)
      (raise-arguments-error
       'player-agent-register!
       "appId must contain exactly 64 hexadecimal characters"
       "appId" app-id))
    (with-state-lock
     value
     (λ ()
       (let ((existing (agent-by-id value app-id)))
         (if existing
             (begin
               (set-playback-agent-name! existing suggested-name)
               (let ((agent-output (agent-renderer value existing)))
                 (when agent-output
                   (set-renderer-name! agent-output suggested-name)))
               (set-playback-agent-last-seen!
                existing
                (current-seconds))
               (hasheq 'name (playback-agent-name existing)
                       'pollIntervalMs 1000))
             (let* ((name
                     (if (string=? suggested-name "")
                         "RKT playback agent"
                         suggested-name))
                    (agent
                     (playback-agent
                      app-id name (current-seconds)
                      (hasheq 'state "stopped"
                              'position 0
                              'volume 50)
                      '() 1 #f #f 0)))
               (set-player-agents!
                value
                (append (player-agents value) (list agent)))
               (set-player-renderers!
                value
                (append
                 (player-renderers value)
                 (list (renderer (agent-renderer-id app-id)
                                 name
                                 'agent
                                 agent))))
               (hasheq 'name name
                       'pollIntervalMs 1000))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Accept agent state and return its oldest unacknowledged command.
; pre    : The agent was registered with player-agent-register!.
; post   : State, heartbeat, acknowledgements and end-of-track are incorporated.
; result : Poll response containing the current agent name and optional command.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (player-agent-poll! value data)
  (let ((app-id (json-string data 'appId #f))
        (name (json-string data 'name #f)))
    (unless (valid-agent-id? app-id)
      (raise-arguments-error
       'player-agent-poll!
       "appId must contain exactly 64 hexadecimal characters"
       "appId" app-id))
    (call-with-semaphore
     (player-command-lock value)
     (λ ()
       (let ((agent (agent-by-id value app-id)))
         (unless agent
           (raise-arguments-error
            'player-agent-poll!
            "playback agent is not registered"
            "appId" app-id))
         (let* ((ack (json-number data 'ack #f))
                (reported (hash-ref data 'state #f))
                (ended (json-number data 'endedCounter 0))
                (previous-ended
                 (playback-agent-ended-counter agent)))
           (with-state-lock
            value
            (λ ()
              (set-playback-agent-last-seen! agent (current-seconds))
              (when (and name
                         (not (string=? (string-trim name) "")))
                (let ((trimmed (string-trim name))
                      (agent-output (agent-renderer value agent)))
                  (set-playback-agent-name! agent trimmed)
                  (when agent-output
                    (set-renderer-name! agent-output trimmed))))
              (when (hash? reported)
                (set-playback-agent-reported-state! agent reported))
              (when (exact-nonnegative-integer? ack)
                (set-playback-agent-commands!
                 agent
                 (filter
                  (λ (command)
                    (> (hash-ref command 'id) ack))
                  (playback-agent-commands agent))))
              (when (exact-nonnegative-integer? ended)
                (set-playback-agent-ended-counter! agent ended))))
           (when (and (> ended previous-ended)
                      (string=? (player-selected-id value)
                                (agent-renderer-id app-id))
                      (eq? (player-backend value) agent))
             (let ((index (next-index value 1)))
               (if index
                   (play-index! value index)
                   (stop-playback! value))))
           (hasheq
            'name (playback-agent-name agent)
            'command
            (if (null? (playback-agent-commands agent))
                'null
                (car (playback-agent-commands agent))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Resolve the current opaque media token for one playback agent.
; pre    : App id and token came from a play command returned by agent polling.
; post   : No state changes.
; result : The local track path, or #f when the token is invalid or expired.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (player-agent-media value app-id token)
  (with-state-lock
   value
   (λ ()
     (let ((agent (and (valid-agent-id? app-id)
                       (agent-by-id value app-id))))
       (and agent
            (string? token)
            (equal? token (playback-agent-media-token agent))
            (playback-agent-media-file agent))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Stop playback and release all player resources.
; pre    : Value was created with make-player.
; post   : The active backend is closed; repeated calls are harmless.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (player-close! value)
  (call-with-semaphore
   (player-command-lock value)
   (λ ()
     (unless (player-closed? value)
       (close-backend! value)
       (with-state-lock
        value
        (λ ()
          (set-player-closed?! value #t)))))))

(module+ test
  (require rackunit
           racket/file)

  (define root
    (make-temporary-file "rkt-web-player-~a" 'directory))

  (dynamic-wind
    void
    (λ ()
      (make-directory (build-path root "Album"))
      (let* ((libraries (make-music-libraries (list root)))
             (example-player (make-player libraries))
             (initial-state
              (player-state->jsexpr example-player)))
        (check-equal? (hash-ref initial-state 'state) "stopped")
        (check-equal? (hash-ref initial-state 'rendererId) "local")
        (check-equal? (length (hash-ref initial-state 'libraries)) 1)
        (check-equal?
         (length (hash-ref (hash-ref initial-state 'browser) 'entries))
         1)
        (check-equal? (length (hash-ref initial-state 'tracks)) 0)

        (define browsed-state
          (player-command!
           example-player
           "browse"
           (hasheq 'index 0)))

        (check-equal?
         (hash-ref (hash-ref browsed-state 'browser) 'path)
         '("Album"))
        (check-true
         (hash-ref (hash-ref browsed-state 'browser) 'canGoUp))

        (define root-state
          (player-command! example-player "up" (hasheq)))

        (check-equal?
         (hash-ref (hash-ref root-state 'browser) 'path)
         '())

        (define repeat-state
          (player-command!
           example-player
           "repeat"
           (hasheq 'mode "all")))

        (check-equal? (hash-ref repeat-state 'repeat) "all")

        (define tab-state
          (player-command!
           example-player
           "tab-add"
           (hasheq)))

        (check-equal? (length (hash-ref tab-state 'tabs)) 2)
        (check-equal? (hash-ref tab-state 'currentTab) 1)

        (define renamed-state
          (player-command!
           example-player
           "tab-rename"
           (hasheq 'index 1 'name "Favorieten")))

        (check-equal?
         (hash-ref (list-ref (hash-ref renamed-state 'tabs) 1) 'name)
         "Favorieten")

        (define deleted-state
          (player-command!
           example-player
           "tab-delete"
           (hasheq 'index 1)))

        (check-equal? (length (hash-ref deleted-state 'tabs)) 1)

        (define test-agent-id
          (make-string 64 #\a))

        (define registration
          (player-agent-register!
           example-player
           (hasheq 'appId test-agent-id
                   'name "Test laptop")))

        (check-equal? (hash-ref registration 'name) "Test laptop")

        (define agent-renderer-state
          (player-command!
           example-player
           "renderer"
           (hasheq 'id (agent-renderer-id test-agent-id))))

        (check-equal?
         (hash-ref agent-renderer-state 'rendererId)
         (agent-renderer-id test-agent-id))

        (player-command!
         example-player
         "volume"
         (hasheq 'value 25))

        (define first-poll
          (player-agent-poll!
           example-player
           (hasheq 'appId test-agent-id
                   'ack 0
                   'endedCounter 0
                   'state
                   (hasheq 'state "stopped"
                           'position 0
                           'volume 25))))

        (check-equal?
         (hash-ref (hash-ref first-poll 'command) 'action)
         "volume")

        (define first-command-id
          (hash-ref (hash-ref first-poll 'command) 'id))

        (define acknowledged-poll
          (player-agent-poll!
           example-player
           (hasheq 'appId test-agent-id
                   'ack first-command-id
                   'endedCounter 0
                   'state
                   (hasheq 'state "stopped"
                           'position 0
                           'volume 25))))

        (check-eq? (hash-ref acknowledged-poll 'command) 'null)

        (check-equal?
         (hash-ref
          (player-agent-register!
           example-player
           (hasheq 'appId test-agent-id
                   'name "Office laptop"))
          'name)
         "Office laptop")
        (check-equal?
         (renderer-name
          (findf
           (λ (item)
             (string=? (renderer-id item)
                       (agent-renderer-id test-agent-id)))
           (player-renderers example-player)))
         "Office laptop")

        (check-exn exn:fail?
                   (λ ()
                     (player-command!
                      example-player
                      "unknown"
                      (hasheq))))
        (player-close! example-player)))
    (λ ()
      (delete-directory/files root))))