resolved conflict

private-player-agent/http-transfer.rkt

@@ -0,0 +1,120 @@
+#lang racket/base
+
+(require racket/async-channel)
+
+(provide call-with-http-timeout)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Bound HTTP inactivity while allowing transfers of any duration.
+; pre    : Seconds is positive. Proc consumes its HTTP ports before returning
+;          and calls progress! whenever new response bytes arrive.
+; post   : The worker has exited and its HTTP resources have been closed.
+; result : Proc's values, or its exception, or an inactivity timeout error.
+; internals: Activity restarts sync/timeout. On cancellation, a break unwinds
+;            semaphore and dynamic-wind cleanup before the custodian closes
+;            remaining ports. No timed-out worker can continue changing state.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (call-with-http-timeout seconds proc)
+  (let* ((custodian (make-custodian))
+         (activity (make-async-channel 1))
+         (result (make-async-channel))
+         (finished? #f)
+         (worker
+          (parameterize ((current-custodian custodian))
+            (thread
+             (λ ()
+               (with-handlers ((exn:break? void))
+                 (parameterize-break #t
+                   (with-handlers
+                       ((exn? (λ (exception)
+                                (async-channel-put result (cons #f exception)))))
+                     (let ((values-list
+                            (call-with-values
+                             (λ () (proc (λ () (async-channel-put activity #t))))
+                             list)))
+                       (async-channel-put result (cons #t values-list)))))))))))
+    (dynamic-wind
+      void
+      (λ ()
+        (let loop ()
+          (let ((event (sync/timeout seconds
+                                    (handle-evt result (λ (value) (cons 'result value)))
+                                    (handle-evt activity (λ (_) 'progress)))))
+            (cond
+              ((not event)
+               (error 'http-transfer "No HTTP progress for ~a seconds" seconds))
+              ((eq? event 'progress) (loop))
+              (else
+               (set! finished? #t)
+               (if (cadr event)
+                   (apply values (cddr event))
+                   (raise (cddr event))))))))
+      (λ ()
+        (unless (or finished? (thread-dead? worker))
+          (break-thread worker))
+        (thread-wait worker)
+        (custodian-shutdown-all custodian)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tests for module http-transfer.rkt
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module+ test
+  (require rackunit racket/file)
+
+  (check-equal? (call-with-values
+                (λ () (call-with-http-timeout 1 (λ (_) (values 1 2)))) list)
+                '(1 2))
+  (check-exn #rx"original failure"
+             (λ () (call-with-http-timeout 1 (λ (_) (error "original failure")))))
+
+  (test-case "continuing progress allows a transfer longer than its idle limit"
+    (check-equal?
+     (call-with-http-timeout
+      0.5
+      (λ (progress!)
+        (let loop ((chunks 6))
+          (unless (zero? chunks)
+            (sleep 0.15)
+            (progress!)
+            (loop (- chunks 1))))
+        'downloaded))
+     'downloaded))
+
+  (test-case "stalled HTTP workers release locks and close their ports"
+    (let ((lock (make-semaphore 1))
+          (output #f)
+          (target (make-temporary-file "http-stall-~a")))
+      (dynamic-wind
+        void
+        (λ ()
+          (check-exn
+           #rx"No HTTP progress"
+           (λ ()
+             (parameterize-break #f
+               (call-with-http-timeout
+                0.1
+                (λ (_)
+                  (set! output (open-output-file target #:exists 'truncate))
+                  (call-with-semaphore lock (λ () (sync never-evt))))))))
+          (check-true (semaphore-try-wait? lock))
+          (check-true (port-closed? output)))
+        (λ () (delete-file target)))))
+
+  (test-case "breaking the caller also unwinds its HTTP worker"
+    (let* ((ready (make-semaphore))
+           (lock (make-semaphore 1))
+           (caller
+            (thread
+             (λ ()
+               (with-handlers ((exn:break? void))
+                 (call-with-http-timeout
+                  5
+                  (λ (_)
+                    (call-with-semaphore
+                     lock
+                     (λ () (semaphore-post ready) (sync never-evt))))))))))
+      (semaphore-wait ready)
+      (break-thread caller)
+      (check-not-false (sync/timeout 2 caller))
+      (check-true (semaphore-try-wait? lock)))))

private-player-agent/player-agent-core.rkt

@@ -9,7 +9,8 @@
          racket/port
          racket/string
          simple-log
-         "player-agent-translate.rkt")
+         "player-agent-translate.rkt"
+         "http-transfer.rkt")
 
 (provide (struct-out player-agent-runtime)
          make-player-agent-runtime)
@@ -44,6 +45,9 @@
 ;;; Posts JSON to an agent API endpoint and reads its JSON response.
 ;;; Authorization failures receive a distinct exception for poll-loop.
 (define (post-json base path data)
+  (call-with-http-timeout
+   30
+   (λ (_progress!)
      (let ((input
             (post-pure-port
              (endpoint-url base path)
@@ -64,7 +68,7 @@
                      (current-continuation-marks)))
                    (error 'player-agent (hash-ref response 'error))))
              response))
-      (λ () (close-input-port input)))))
+         (λ () (close-input-port input)))))))
 
 ;;; Converts racket-audio states to the state names sent to the web player.
 (define (normal-state state)
@@ -84,6 +88,21 @@
                         (exn-message exception)))))
       (delete-file file))))
 
+;;; Copies media in bounded chunks, reporting bytes written without waiting
+;;; for a full buffer; slow network streams therefore still show progress.
+(define (copy-media-port input output progress! #:idle-timeout [idle-timeout 60])
+  (let ((buffer (make-bytes 65536)))
+    (let loop ((received 0))
+      (unless (sync/timeout idle-timeout input)
+        (error 'player-agent
+               "Download timeout: no data received for ~a seconds (~a bytes received)"
+               idle-timeout received))
+      (let ((count (read-bytes-avail! buffer input)))
+        (unless (eof-object? count)
+          (write-bytes buffer output 0 count)
+          (progress! (+ received count))
+          (loop (+ received count)))))))
+
 ;;; Evicts least recently used files until the cache fits its byte budget.
 ;;; Entries contain path, byte size and last use; active files remain protected.
 (define (trim-media-cache! cache protected [limit 1000000000])
@@ -151,6 +170,7 @@
          (pending-auto-music-id #f)
          (music-tracks (make-hash))
          (current-track-value #f)
+         (download-progress 'null)
          (acknowledged-command 0)
          (ended-counter 0)
          (logical-volume 50)
@@ -173,9 +193,11 @@
   (define (state-value value fallback)
     (if (eq? value #f) fallback value))
 
-  ;;; Returns the latest audio state while holding the state semaphore.
+  ;;; Combines audio and download state under the semaphore so audio callbacks
+  ;;; cannot erase progress while the next track is being prefetched.
   (define (snapshot)
-    (with-agent-state (λ () agent-state)))
+    (with-agent-state
+     (λ () (hash-set agent-state 'download download-progress))))
 
   ;;; Returns the currently audible track while holding the state semaphore.
   (define (current-track)
@@ -210,7 +232,7 @@
                 'format (let ((decoder (hash-ref full-state 'decoder #f)))
                           (if decoder (format "~a" decoder) ""))
                 'volume logical-volume
-                'error 'null))
+                'error (hash-ref agent-state 'error 'null)))
          (when (and pending-auto-music-id
                     (number? audible-music-id)
                     (= pending-auto-music-id audible-music-id))
@@ -243,7 +265,7 @@
 
   ;;; Downloads one protected media resource to a temporary local file.
   ;;; A failed download closes its port and removes its partial file.
-  (define (download-media! token filename)
+  (define (download-media-once! token filename size)
     (let* ((started (current-inexact-monotonic-milliseconds))
            (extension
             (or (path-get-extension (string->path filename)) #""))
@@ -253,24 +275,65 @@
                             (bytes->string/utf-8 extension))))
            (path (format "/api/agent/media/~a/~a" app-id token))
            (input #f))
-      (with-handlers ((exn:fail?
+      (with-handlers ((exn?
                        (λ (exception)
                          (when input (close-input-port input))
                          (safe-delete-file target)
+                         (with-agent-state
+                          (λ () (set! download-progress 'null)))
                          (raise exception))))
         (info-player-agent "Downloading ~a" filename)
+        (with-agent-state
+         (λ ()
+           (set! download-progress
+                 (hasheq 'filename filename 'received 0
+                         'total (if (exact-nonnegative-integer? size)
+                                    size 'null)))))
+        (call-with-http-timeout
+         30
+         (λ (progress!)
           (set! input (get-pure-port (endpoint-url server-url path)))
           (call-with-output-file
            target
-         (λ (output) (copy-port input output))
+           (λ (output)
+             (copy-media-port
+              input output
+              (λ (received)
+                (progress!)
+                (with-agent-state
+                 (λ ()
+                   (set! download-progress
+                         (hash-set download-progress 'received received)))))))
            #:exists 'truncate/replace)
-        (close-input-port input)
+          (close-input-port input)))
+        (when (and (exact-nonnegative-integer? size)
+                   (not (= (file-size target) size)))
+          (error 'player-agent
+                 "Incomplete media download: received ~a of ~a bytes"
+                 (file-size target) size))
+        (with-agent-state (λ () (set! download-progress 'null)))
         (info-player-agent "Downloaded ~a: ~a bytes in ~a ms"
                            filename (file-size target)
                            (round (- (current-inexact-monotonic-milliseconds)
                                      started)))
         target)))
 
+  ;;; Retries interrupted downloads twice before reporting a final failure.
+  ;;; Each attempt removes its partial file; the media token stays unacknowledged.
+  (define (download-media! token filename size)
+    (let loop ((attempt 1))
+      (with-handlers
+          ((exn:fail?
+            (λ (exception)
+              (if (< attempt 3)
+                  (begin
+                    (warn-player-agent "Download attempt ~a failed for ~a: ~a; retrying"
+                                       attempt filename (exn-message exception))
+                    (sleep 1)
+                    (loop (+ attempt 1)))
+                  (raise exception)))))
+        (download-media-once! token filename size))))
+
   ;;; Scopes media identity to its server, source path, size and modification time.
   ;;; Older servers without version metadata only reuse the same media token.
   (define (command-cache-key data)
@@ -299,12 +362,8 @@
           (let ((downloaded
                  (download-media!
                   (hash-ref data 'mediaToken)
-                  (hash-ref data 'filename "track"))))
-            (when (and (hash-has-key? data 'mediaSize)
-                       (not (= (file-size downloaded)
-                               (hash-ref data 'mediaSize))))
-              (safe-delete-file downloaded)
-              (error 'player-agent "Downloaded media size does not match the server"))
+                  (hash-ref data 'filename "track")
+                  (hash-ref data 'mediaSize #f))))
             (with-agent-state
              (λ ()
                (when found (safe-delete-file (car found)))
@@ -507,21 +566,39 @@
               (set! command-worker
                     (thread
                      (λ ()
+                       (with-handlers ((exn:break? void))
+                         (parameterize-break #t
                            (with-handlers
                                ((exn:fail?
                                  (λ (exception)
                                    (warn-player-agent "Command failed: ~a"
                                                       (exn-message exception))
+                                   (when (and audio
+                                              (equal? (hash-ref command 'action) "play"))
+                                     (with-handlers
+                                         ((exn:fail?
+                                           (λ (stop-exception)
+                                             (warn-player-agent
+                                              "Could not stop audio after failed play: ~a"
+                                              (exn-message stop-exception)))))
+                                       (audio-stop! audio)))
                                    (with-agent-state
                                     (λ ()
                                       (set! loading-media-key #f)
+                                      (when (equal? (hash-ref command 'action) "play")
+                                        (set! agent-state
+                                              (hash-set* agent-state
+                                                         'state "stopped"
+                                                         'position 0)))
                                       (trim-cache!)))
                                    (set-agent-error! (exn-message exception)))))
-                         (clear-agent-error!)
+                             ;; A queued prefetch must not erase a failed play's error.
+                             (unless (equal? (hash-ref command 'action) "prefetch")
+                               (clear-agent-error!))
                              (execute-command! command))
                            (set! acknowledged-command (hash-ref command 'id))
                            (set! executing-command-id 0)
-                       (set! command-worker #f))))))
+                           (set! command-worker #f))))))))
           (sleep 1)
           (loop)))))
 
@@ -530,17 +607,26 @@
     (unless running
       (set! running #t)
       (status-callback (tr 'connecting))
-      (set! worker (thread poll-loop))))
+      (set! worker
+            (thread
+             (λ ()
+               (with-handlers ((exn:break? void))
+                 (parameterize-break #t (poll-loop))))))))
 
   ;;; Stops polling and command workers and clears their lifecycle state.
   (define (stop!)
     (set! running #f)
-    (when (and worker (not (thread-dead? worker)))
-      (kill-thread worker))
-    (when (and command-worker (not (thread-dead? command-worker)))
-      (kill-thread command-worker))
+    (let ((poll-worker worker)
+          (active-command command-worker))
+      (when (and poll-worker (not (thread-dead? poll-worker)))
+        (break-thread poll-worker)
+        (thread-wait poll-worker))
+      (when (and active-command (not (thread-dead? active-command)))
+        (break-thread active-command)
+        (thread-wait active-command)))
     (set! worker #f)
     (set! command-worker #f)
+    (with-agent-state (λ () (set! download-progress 'null)))
     (set! executing-command-id 0))
 
   ;;; Restarts the runtime with a new normalized server address and name.
@@ -577,7 +663,131 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (module+ test
-  (require rackunit)
+  (require rackunit
+           racket/async-channel
+           web-server/http
+           web-server/http/json
+           web-server/web-server
+           (prefix-in lift: web-server/dispatchers/dispatch-lift))
+
+  ;; Exercise real polling after three truncated downloads. A queued prefetch
+  ;; must preserve the error, and a subsequent Stop must still be processed.
+  (test-case "failed download reports stopped and accepts subsequent commands"
+    (let* ((ready (make-async-channel))
+           (done (make-semaphore 0))
+           (attempts 0)
+           (prefetch-attempts 0)
+           (reports (make-hash))
+           (runtime #f)
+           (stop-server
+            (serve
+             #:port 0 #:listen-ip "127.0.0.1"
+             #:confirmation-channel ready #:connection-close? #t
+             #:dispatch
+             (lift:make
+              (λ (request)
+                (let ((path (url->string (request-uri request))))
+                  (cond
+                    ((equal? path "/api/agent/register")
+                     (response/jsexpr (hasheq)))
+                    ((equal? path "/api/agent/poll")
+                     (let* ((data (bytes->jsexpr (request-post-data/raw request)))
+                            (ack (hash-ref data 'ack))
+                            (command
+                             (case ack
+                               ((0) (hasheq 'id 1 'action "play"
+                                            'data (hasheq 'mediaToken "broken"
+                                                          'filename "broken.flac"
+                                                          'mediaSize 8)))
+                               ((1) (hasheq 'id 2 'action "prefetch"
+                                            'data (hasheq 'mediaToken "next"
+                                                          'filename "next.flac"
+                                                          'mediaSize 4)))
+                               ((2) (hasheq 'id 3 'action "stop"))
+                               (else 'null))))
+                       (hash-set! reports ack (hash-ref data 'state))
+                       (when (= ack 3) (semaphore-post done))
+                       (response/jsexpr (hasheq 'command command))))
+                    (else
+                     (when (regexp-match? #rx"broken$" path)
+                       (set! attempts (+ attempts 1)))
+                     (when (regexp-match? #rx"next$" path)
+                       (set! prefetch-attempts (+ prefetch-attempts 1)))
+                     (let ((body (if (and (regexp-match? #rx"next$" path)
+                                          (= prefetch-attempts 1))
+                                     #"12" #"1234")))
+                       (response/output
+                        (λ (output) (write-bytes body output))
+                        #:headers
+                        (list (header #"Content-Length"
+                                      (string->bytes/utf-8
+                                       (number->string (bytes-length body)))))))))))))))
+      (dynamic-wind
+        void
+        (λ ()
+          (let ((port (async-channel-get ready)))
+            (when (exn? port) (raise port))
+            (set! runtime
+                  (make-player-agent-runtime
+                   (format "http://127.0.0.1:~a" port) "Test" (make-string 64 #\a)))
+            ((player-agent-runtime-start! runtime))
+            (check-not-false (sync/timeout 15 done))
+            (check-equal? attempts 3)
+            (check-equal? prefetch-attempts 2)
+            (let ((failed (hash-ref reports 1 (hasheq)))
+                  (prefetched (hash-ref reports 2 (hasheq)))
+                  (stopped (hash-ref reports 3 (hasheq))))
+              (check-equal? (hash-ref failed 'state #f) "stopped")
+              (check-regexp-match #rx"received 4 of 8 bytes"
+                                  (hash-ref failed 'error ""))
+              (check-equal? (hash-ref failed 'download #f) 'null)
+              (check-equal? (hash-ref prefetched 'error #f)
+                            (hash-ref failed 'error ""))
+              (check-equal? (hash-ref stopped 'error #f) 'null)
+              (check-true ((player-agent-runtime-running? runtime))))))
+        (λ ()
+          (when runtime ((player-agent-runtime-shutdown! runtime)))
+          (stop-server)))))
+
+  ;; An open stream that stops delivering bytes must not occupy the worker forever.
+  (let-values (((input writer) (make-pipe)))
+    (dynamic-wind
+      void
+      (λ ()
+        (check-exn #rx"Download timeout: no data received"
+                   (λ ()
+                     (copy-media-port input (open-output-bytes) void
+                                      #:idle-timeout 0.02))))
+      (λ () (close-input-port input) (close-output-port writer))))
+
+  ;; Progress must arrive before EOF, even when a slow server has sent much
+  ;; less than one buffer. Binary data must reach the output unchanged.
+  (let-values (((input writer) (make-pipe)))
+    (let* ((output (open-output-bytes))
+           (updates (make-channel))
+           (worker
+            (thread
+             (λ ()
+               (copy-media-port input output
+                                (λ (received)
+                                  (channel-put updates received)))))))
+      (dynamic-wind
+        void
+        (λ ()
+          (write-bytes #"\0\1\377" writer)
+          (flush-output writer)
+          (check-equal? (sync/timeout 5 updates) 3)
+          (check-equal? (get-output-bytes output) #"\0\1\377")
+          (write-bytes #"next" writer)
+          (close-output-port writer)
+          (check-equal? (sync/timeout 5 updates) 7)
+          (check-not-false (sync/timeout 5 worker))
+          (check-equal? (get-output-bytes output) #"\0\1\377next"))
+        (λ ()
+          (kill-thread worker)
+          (close-input-port input)
+          (close-output-port writer)
+          (close-output-port output)))))
 
   (check-equal? (normal-state 'initialized) "stopped")
   (check-equal? (normal-state 'transitioning) "starting")
@@ -620,6 +830,9 @@
                                      app-id)))
     (check-false ((player-agent-runtime-running? runtime)))
     (check-false ((player-agent-runtime-current-track runtime)))
+    (check-equal?
+     (hash-ref ((player-agent-runtime-snapshot runtime)) 'download)
+     'null)
     (check-equal?
      (hash-ref ((player-agent-runtime-snapshot runtime)) 'state)
      "stopped")

private-player-agent/player-agent-gui.rkt

@@ -95,6 +95,10 @@
         (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)
@@ -163,6 +167,7 @@
       (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)))
@@ -210,6 +215,36 @@
                            (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
@@ -385,6 +420,29 @@
                  (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)

private-player-agent/player-agent-translate.rkt

@@ -31,6 +31,7 @@
     'playing "Playing"
     'paused "Paused"
     'loading "Loading"
+    'downloading "Downloading"
     'stopped "Stopped"
     'channel "channel"
     'channels "channels"
@@ -56,6 +57,7 @@
     'playing "Speelt"
     'paused "Gepauzeerd"
     'loading "Laden"
+    'downloading "Downloaden"
     'stopped "Gestopt"
     'channel "kanaal"
     'channels "kanalen"
@@ -82,6 +84,7 @@
     'paused "Pausiert"
     'loading "Laden"
     'stopped "Gestoppt"
+    'downloading "Herunterladen"
     'channel "Kanal"
     'channels "Kanäle"
     'tray-open "RKT Web Player Agent öffnen"
@@ -106,6 +109,7 @@
     'playing "Lecture"
     'paused "En pause"
     'loading "Chargement"
+    'downloading "Téléchargement"
     'stopped "Arrêté"
     'channel "canal"
     'channels "canaux"
@@ -131,6 +135,7 @@
     'playing "Reproduciendo"
     'paused "En pausa"
     'loading "Cargando"
+    'downloading "Descargando"
     'stopped "Detenido"
     'channel "canal"
     'channels "canales"
@@ -156,6 +161,7 @@
     'playing "In riproduzione"
     'paused "In pausa"
     'loading "Caricamento"
+    'downloading "Download"
     'stopped "Arrestato"
     'channel "canale"
     'channels "canali"
@@ -181,6 +187,7 @@
     'playing "Spelar"
     'paused "Pausad"
     'loading "Läser in"
+    'downloading "Laddar ned"
     'stopped "Stoppad"
     'channel "kanal"
     'channels "kanaler"
@@ -206,6 +213,7 @@
     'playing "Spiller"
     'paused "På pause"
     'loading "Laster"
+    'downloading "Laster ned"
     'stopped "Stoppet"
     'channel "kanal"
     'channels "kanaler"
@@ -231,6 +239,7 @@
     'playing "Toistetaan"
     'paused "Keskeytetty"
     'loading "Ladataan"
+    'downloading "Ladataan tiedostoa"
     'stopped "Pysäytetty"
     'channel "kanava"
     'channels "kanavaa"
@@ -256,6 +265,7 @@
     'playing "Spilar"
     'paused "Í bið"
     'loading "Hleður"
+    'downloading "Sæki"
     'stopped "Stöðvað"
     'channel "rás"
     'channels "rásir"

private/dlna-playback.rkt

@@ -359,7 +359,10 @@
                          (make-semaphore 1))))
     (set-dlna-playback-monitor!
      playback
-     (thread (λ () (monitor-loop playback poll-seconds))))
+     (thread (λ ()
+               (with-handlers ((exn:break? void))
+                 (parameterize-break #t
+                   (monitor-loop playback poll-seconds))))))
     playback))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -483,7 +486,9 @@
     (set-dlna-playback-running?! playback #f)
     (let ((monitor (dlna-playback-monitor playback)))
       (when (and monitor (not (thread-dead? monitor)))
-        (kill-thread monitor))
+        ;; A break unwinds call-with-semaphore; kill-thread leaves its lock held.
+        (break-thread monitor)
+        (thread-wait monitor))
       (set-dlna-playback-monitor! playback #f)
       (with-lock
        playback

private/player.rkt

@@ -1461,6 +1461,11 @@
                         (player-renderers value))
         'rendererId (or (playback-session-selected-id session) 'null)
         'currentIndex (or (playback-session-current-index session) 'null)
+        'download
+        (let ((backend (playback-session-backend session)))
+          (if (and backend (eq? (playback-session-backend-kind session) 'agent))
+              (hash-ref (playback-agent-reported-state backend) 'download 'null)
+              'null))
         'state (symbol->string (playback-session-state session))
         'position (playback-session-position session)
         'duration (or (playback-session-duration session) 'null)
@@ -2154,7 +2159,13 @@
                    'state
                    (hasheq 'state "stopped"
                            'position 0
-                           'volume 25))))
+                           'volume 25
+                           'download (hasheq 'filename "Large.flac"
+                                             'received 65536 'total 100000000)))))
+
+        (check-equal?
+         (hash-ref (player-state->jsexpr example-player) 'download)
+         (hasheq 'filename "Large.flac" 'received 65536 'total 100000000))
 
         (check-equal?
          (hash-ref (hash-ref first-poll 'command) 'action)

private/server.rkt

@@ -7,10 +7,13 @@
          racket/runtime-path
          racket-mimetypes
          racket/string
+         racket/path
+         simple-log
          net/url
          web-server/dispatch
          web-server/http
          web-server/http/json
+         web-server/safety-limits
          web-server/servlet-env
          "library.rkt"
          "player.rkt"
@@ -18,6 +21,8 @@
 
 (provide serve-player)
 
+(sl-def-log web-player-http)
+
 (define-runtime-path public-directory "../public")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -175,16 +180,47 @@
       player
       (request-jsexpr request)))))
 
+;;; Streams an agent download without holding player locks and reports its
+;;; start, progress and outcome, including the client and actual bytes sent.
+(define (stream-agent-media! file output client app-id)
+  (let ((received 0)
+        (total (file-size file))
+        (started (current-inexact-monotonic-milliseconds))
+        (reported (current-inexact-monotonic-milliseconds))
+        (completed? #f)
+        (name (file-name-from-path file)))
+    (dynamic-wind
+      (λ () (info-web-player-http "Agent download started: client=~a agent=~a file=~a bytes=~a"
+                                  client (substring app-id 0 8) name total))
+      (λ ()
+        (call-with-input-file
+         file
+         (λ (input)
+           (let ((buffer (make-bytes 65536)))
+             (let loop ()
+               (let ((count (read-bytes-avail! buffer input)))
+                 (unless (eof-object? count)
+                   (write-bytes buffer output 0 count)
+                   (set! received (+ received count))
+                   (when (>= (- (current-inexact-monotonic-milliseconds) reported) 5000)
+                     (set! reported (current-inexact-monotonic-milliseconds))
+                     (info-web-player-http "Agent download progress: client=~a file=~a bytes=~a/~a"
+                                           client name received total))
+                   (loop)))))))
+        (flush-output output)
+        (set! completed? #t))
+      (λ ()
+        (info-web-player-http "Agent download ~a: client=~a file=~a bytes=~a/~a elapsed-ms=~a"
+                              (if completed? "sent" "interrupted") client name received total
+                              (round (- (current-inexact-monotonic-milliseconds) started)))))))
+
 ;;; Streams the media file identified by an agent's opaque token.
-(define (agent-media-handler player _request app-id token)
+(define (agent-media-handler player request app-id token)
   (let ((file (player-agent-media player app-id token)))
     (if (and file (file-exists? file))
         (response/output
          (λ (output)
-           (call-with-input-file
-            file
-            (λ (input)
-              (copy-port input output))))
+           (stream-agent-media! file output (request-client-ip request) app-id))
          #:mime-type
          (let ((mime (mimetype-for-ext file)))
            (if (string? mime)
@@ -377,6 +413,10 @@
      #:listen-ip listen-ip
      #:port port
      #:connection-close? #t
+     ;; Content-Length responses use one timeout for the entire copy-port.
+     ;; Large lossless tracks can take several minutes over a healthy link.
+     #:safety-limits (make-safety-limits #:response-timeout 3600
+                                        #:response-send-timeout 3600)
      #:launch-browser? launch-browser?
      #:quit? #f
      #:banner? #t

public/app.js

@@ -146,12 +146,21 @@ async function api(path, body) {
     };
   }
 
-  const response = await fetch(path, options);
+  const controller = new AbortController();
+  const timeout = setTimeout(() => controller.abort(), 30000);
+  try {
+    const response = await fetch(path, { ...options, signal: controller.signal });
     const data = await response.json();
     if (!response.ok) {
       throw new ApiError(data.error || `HTTP ${response.status}`, response.status, data.code);
     }
     return data;
+  } catch (error) {
+    if (controller.signal.aborted) throw new Error("request-timeout");
+    throw error;
+  } finally {
+    clearTimeout(timeout);
+  }
 }
 
 // Displays the login overlay and optionally reports why authentication failed.
@@ -671,6 +680,11 @@ function render(nextState) {
   renderPlayer(nextState);
   if (nextState.error) {
     setStatus(t(nextState.error));
+  } else if (nextState.download) {
+    const download = nextState.download;
+    const received = (download.received / 1000000).toFixed(1);
+    const total = Number.isFinite(download.total) ? (download.total / 1000000).toFixed(1) : "?";
+    setStatus(t("downloadingMedia", { name: download.filename, received, total }));
   } else {
     setStatus(nextState.discovering ? t("searchingPlayers") : "");
   }

public/translate.js

@@ -3,6 +3,8 @@
 
   const translations = {
     en: {
+      "request-timeout": "The server did not respond within 30 seconds. Status will be refreshed automatically.",
+      downloadingMedia: "Downloading {name}: {received} / {total} MB",
       folders: "Folders",
       savePlaylist: "SAVE PLAYLIST",
       playlistSaved: "SAVED",
@@ -41,6 +43,8 @@
       "dlna-renderer-unreachable": "The DLNA renderer is unreachable.",
     },
     nl: {
+      "request-timeout": "De server antwoordde niet binnen 30 seconden. De status wordt automatisch opnieuw opgehaald.",
+      downloadingMedia: "Downloaden van {name}: {received} / {total} MB",
       folders: "Mappen",
       savePlaylist: "AFSPEELLIJST OPSLAAN",
       playlistSaved: "OPGESLAGEN",

scribblings/rkt-web-player.scrbl

@@ -141,6 +141,25 @@ in-progress download can temporarily exceed the budget. The cache lasts until
 the agent exits; it is not retained across restarts.
 
 A track that is not cached is still downloaded completely before playback.
+The HTTP server allows up to one hour for a response, including media
+transfers, so large lossless tracks can finish over slower connections.
+The agent imposes no total download deadline: receiving another chunk restarts
+its 30-second inactivity timer. A connection or transfer with no response bytes
+for 30 seconds fails, closes its ports and removes the partial file. The private
+@tt{call-with-http-timeout} procedure runs an HTTP operation with a
+@tt{progress!} callback; each callback restarts this timer. Cancellation unwinds
+the worker before its custodian closes the remaining HTTP resources.
+
+The browser displays the selected agent's reported download filename and byte
+counts, including prefetch downloads. Server logs record agent download start,
+progress every five seconds while sending, and completion or interruption with
+client address, filename and byte counts. DLNA media transfers are logged by
+@tt{racket-upnp} with client address, method, range and elapsed time.
+
+Browser API requests time out after 30 seconds, freeing the request queue and
+allowing status polling to resume. Timing out a browser request does not undo a
+command already accepted by the server.
+
 The next track is fetched after the play command completes. Commands are
 processed in server order, so a pending prefetch can still delay a later manual
 track selection.
@@ -345,6 +364,17 @@ configured RKT Web Player server, downloads assigned tracks over HTTP, and
 plays them with @tt{racket-audio}. Its configured display name is authoritative
 and is followed by the server. Importing the module does not start the GUI; the
 function must be called explicitly.
+During downloads, including prefetching the next track, the GUI shows the
+filename and received megabytes. When the server supplies the file size,
+it also shows the total size, percentage and a progress bar. The display
+updates every half second and disappears when the download finishes or fails.
+Interrupted downloads are retried twice, starting again from the beginning.
+After 60 seconds without incoming media data, the agent aborts the attempt
+instead of waiting indefinitely. If all three attempts fail, a failed play
+returns to the stopped state and the GUI displays the error, including byte
+counts for an incomplete file. Background prefetching and audio status updates
+preserve this message; a new playback command clears it. Polling continues,
+so subsequent commands can still be processed.
 The GUI and its @tt{racket-tray} system tray support the same ten languages
 based on the operating-system language, with English as fallback. Closing or
 minimizing the window hides it in the tray. The tray menu restores the window