DLNA playback

private/player.rkt

@@ -47,6 +47,18 @@
   (id [name #:mutable] [tracks #:mutable])
   #:transparent)
 
+(struct network-playback
+  ([current-uri #:mutable]
+   [prepared-uri #:mutable]
+   [prepared-index #:mutable]
+   [playing-seen? #:mutable]
+   [progress-seen? #:mutable]
+   [failure-active? #:mutable]
+   [stop-requested? #:mutable]
+   [stopped-polls #:mutable]
+   [play-request-ms #:mutable])
+  #:transparent)
+
 (struct player
   (libraries
    allowed-agent-ids
@@ -74,9 +86,11 @@
    [error #:mutable]
    [discovering? #:mutable]
    [closed? #:mutable]
+   [network-monitor #:mutable]
    state-lock
    command-lock
    local-music-indexes
+   network
    dlna-port)
   #:transparent)
 
@@ -247,6 +261,94 @@
   (set-player-bits! value #f)
   (set-player-decoder! value #f))
 
+(define (now-ms)
+  (current-inexact-milliseconds))
+
+(define (reset-network-playback! value)
+  (define network (player-network value))
+  (set-network-playback-current-uri! network #f)
+  (set-network-playback-prepared-uri! network #f)
+  (set-network-playback-prepared-index! network #f)
+  (set-network-playback-playing-seen?! network #f)
+  (set-network-playback-progress-seen?! network #f)
+  (set-network-playback-failure-active?! network #f)
+  (set-network-playback-stop-requested?! network #f)
+  (set-network-playback-stopped-polls! network 0)
+  (set-network-playback-play-request-ms! network #f))
+
+(define (same-track-file? first second)
+  (and first
+       second
+       (with-handlers ((exn:fail? (lambda (_) #f)))
+         (equal? (normal-case-path first)
+                 (normal-case-path second)))))
+
+(define (network-info-track-index value info)
+  (define network (player-network value))
+  (define info-track (dlna-info-track info))
+  (define file (and info-track (dlna-track-info-file info-track)))
+  (define uri (dlna-info-uri info))
+  (define prepared-index (network-playback-prepared-index network))
+  (define prepared-uri (network-playback-prepared-uri network))
+  (cond
+    ((and (valid-track-index? value prepared-index)
+          (or (same-track-file?
+               file
+               (track-file (list-ref (player-tracks value) prepared-index)))
+              (and (string? uri)
+                   (string? prepared-uri)
+                   (string=? uri prepared-uri))))
+     prepared-index)
+    (else
+     (for/first ((item (in-list (player-tracks value)))
+                 (index (in-naturals))
+                 #:when (same-track-file? file (track-file item)))
+       index))))
+
+(define (prepare-next-network-track! value)
+  (define backend (player-backend value))
+  (define network (player-network value))
+  (when (and backend
+             (member (player-backend-kind value) '(upnp sonos))
+             (valid-track-index? value (player-current-index value)))
+    (define index (next-index value 1))
+    (cond
+      ((not index)
+       (set-network-playback-prepared-index! network #f)
+       (set-network-playback-prepared-uri! network #f))
+      ((not (equal? index (network-playback-prepared-index network)))
+       (with-handlers
+           ((exn:fail?
+             (lambda (exception)
+               (set-network-playback-prepared-index! network #f)
+               (set-network-playback-prepared-uri! network #f)
+               (warn-web-player
+                "Could not prepare next DLNA track: ~a"
+                (exn-message exception)))))
+         (dlna-player-set-next-file!
+          backend
+          (track-file (list-ref (player-tracks value) index)))
+         (define prepared-info (dlna-player-info backend))
+         (set-network-playback-prepared-index! network index)
+         (set-network-playback-prepared-uri!
+          network
+          (dlna-info-next-uri prepared-info)))))))
+
+;; Result used when a renderer reports stopped after a play request.
+(define (network-stop-decision stop-requested?
+                               playing-seen?
+                               progress-seen?
+                               elapsed-ms
+                               prepared?
+                               stopped-polls)
+  (cond
+    (stop-requested? 'requested-stop)
+    ((not playing-seen?) 'none)
+    ((and (not progress-seen?) (< elapsed-ms 5000)) 'wait-for-start)
+    ((not progress-seen?) 'playback-failed)
+    ((and prepared? (<= stopped-polls 1)) 'wait-for-next)
+    (else 'advance)))
+
 (define (local-state-callback value handle state full-state)
   (with-state-lock
    value
@@ -363,6 +465,7 @@
     (with-state-lock
      value
      (λ ()
+       (reset-network-playback! value)
        (set-player-backend! value #f)
        (set-player-backend-kind! value #f)
        (set-player-state! value 'stopped)
@@ -380,6 +483,15 @@
                                (player-backend value)
                                "stop"))
       (else
+       (with-state-lock
+        value
+        (λ ()
+          (define network (player-network value))
+          (set-network-playback-stop-requested?! network #t)
+          (set-network-playback-playing-seen?! network #f)
+          (set-network-playback-progress-seen?! network #f)
+          (set-network-playback-failure-active?! network #f)
+          (set-network-playback-stopped-polls! network 0)))
        (dlna-player-stop! (player-backend value)))))
   (with-state-lock
    value
@@ -447,7 +559,24 @@
            (enqueue-agent-command!
             value backend "prefetch" following-data))))
       (else
-       (dlna-player-play! backend (track-file item))))
+       (dlna-player-play! backend (track-file item))
+       (let ((info (dlna-player-info backend)))
+         (with-state-lock
+          value
+          (λ ()
+            (define network (player-network value))
+            (set-network-playback-current-uri!
+             network
+             (dlna-info-uri info))
+            (set-network-playback-prepared-uri! network #f)
+            (set-network-playback-prepared-index! network #f)
+            (set-network-playback-playing-seen?! network #t)
+            (set-network-playback-progress-seen?! network #f)
+            (set-network-playback-failure-active?! network #f)
+            (set-network-playback-stop-requested?! network #f)
+            (set-network-playback-stopped-polls! network 0)
+            (set-network-playback-play-request-ms! network (now-ms)))))
+       (prepare-next-network-track! value)))
     (clear-error! value)))
 
 (define (next-index value direction)
@@ -467,86 +596,172 @@
             (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 playback-changing work. Prefetching does not
-            ;; change playback state and may continue in the background.
-            (when (and (hash? reported)
-                       (andmap
-                        (λ (command)
-                          (string=? (hash-ref command 'action "")
-                                    "prefetch"))
-                        (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
-         (λ ()
+(define (refresh-agent-state! value)
+  (define reported
+    (playback-agent-reported-state (player-backend value)))
+  ;; Keep optimistic command state until playback-changing work is acknowledged.
+  (when (and (hash? reported)
+             (andmap
+              (λ (command)
+                (string=? (hash-ref command 'action "") "prefetch"))
+              (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 (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))))))))))
+            (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)))
+       (set-player-error! value (json-string reported 'error #f))))))
+
+(define (refresh-dlna-state! value)
+  (define info (dlna-player-info (player-backend value)))
+  (define track-info (dlna-info-track info))
+  (define new-state (normalize-state (dlna-info-state info)))
+  (define position (or (dlna-info-position info) 0))
+  (define prepare-next? #f)
+  (define advance? #f)
+  (define playback-failed? #f)
+  (with-state-lock
+   value
+   (λ ()
+     (define network (player-network value))
+     (define uri (dlna-info-uri info))
+     (when (and (string? uri)
+                (not (string=? uri ""))
+                (not (equal? uri (network-playback-current-uri network))))
+       (set-network-playback-current-uri! network uri)
+       (set-network-playback-stopped-polls! network 0)
+       (let ((detected-index (network-info-track-index value info)))
+         (when (valid-track-index? value detected-index)
+           (unless (equal? detected-index (player-current-index value))
+             (set-network-playback-progress-seen?! network #f)
+             (set-network-playback-failure-active?! network #f)
+             (set-network-playback-play-request-ms! network (now-ms)))
+           (set-player-current-index! value detected-index)
+           (set-network-playback-prepared-index! network #f)
+           (set-network-playback-prepared-uri! network #f)
+           (set! prepare-next? #t))))
+
+     (when (and (not (network-playback-failure-active? network))
+                (member new-state '(playing starting paused)))
+       (when (eq? new-state 'playing)
+         (set-network-playback-playing-seen?! network #t)
+         (set-network-playback-stopped-polls! network 0))
+       (when (and (number? position) (> position 0))
+         (set-network-playback-progress-seen?! network #t)))
+
+     (let ((requested-at (network-playback-play-request-ms network)))
+       (when (and (network-playback-playing-seen? network)
+                  (not (network-playback-progress-seen? network))
+                  requested-at
+                  (>= (- (now-ms) requested-at) 8000))
+         (set-network-playback-playing-seen?! network #f)
+         (set-network-playback-stopped-polls! network 0)
+         (set-network-playback-failure-active?! network #t)
+         (set-player-error! value "De DLNA-renderer kon de track niet starten")
+         (set! playback-failed? #t)))
+
+     (when (and (eq? new-state 'stopped)
+                (not playback-failed?)
+                (not (network-playback-failure-active? network)))
+       (when (and (network-playback-playing-seen? network)
+                  (network-playback-progress-seen? network))
+         (set-network-playback-stopped-polls!
+          network
+          (+ 1 (network-playback-stopped-polls network))))
+       (let* ((requested-at (network-playback-play-request-ms network))
+              (decision
+               (network-stop-decision
+                (network-playback-stop-requested? network)
+                (network-playback-playing-seen? network)
+                (network-playback-progress-seen? network)
+                (if requested-at (- (now-ms) requested-at) 10000)
+                (exact-nonnegative-integer?
+                 (network-playback-prepared-index network))
+                (network-playback-stopped-polls network))))
+         (case decision
+           ((requested-stop)
+            (set-network-playback-stop-requested?! network #f)
+            (set-network-playback-stopped-polls! network 0))
+           ((playback-failed)
+            (set-network-playback-playing-seen?! network #f)
+            (set-network-playback-stopped-polls! network 0)
+            (set-network-playback-failure-active?! network #t)
+            (set-player-error! value "De DLNA-renderer kon de track niet starten"))
+           ((advance)
+            (set-network-playback-playing-seen?! network #f)
+            (set-network-playback-stopped-polls! network 0)
+            (set! advance? #t)))))
+
+     (set-player-state!
+      value
+      (cond
+        ((or playback-failed?
+             (network-playback-failure-active? network))
+         'stopped)
+        ((and (network-playback-playing-seen? network)
+              (not (network-playback-progress-seen? network)))
+         'starting)
+        (else new-state)))
+     (set-player-position! value position)
+     (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)))))
+  (when prepare-next?
+    (prepare-next-network-track! value))
+  (when advance?
+    (let ((index (next-index value 1)))
+      (if index
+          (play-index! value index)
+          (stop-playback! value)))))
+
+(define (refresh-network-state! value)
+  (call-with-semaphore
+   (player-command-lock 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)
+             (refresh-agent-state! value)
+             (refresh-dlna-state! value)))))))
+
+(define (start-network-monitor! value)
+  (set-player-network-monitor!
+   value
+   (thread
+    (λ ()
+      (let loop ()
+        (sleep 1)
+        (unless (player-closed? value)
+          (refresh-network-state! value)
+          (loop)))))))
 
 (define (entry-by-index value index)
   (and (exact-nonnegative-integer? index)
@@ -1010,7 +1225,12 @@
        (with-state-lock
         value
         (λ ()
-          (set-player-repeat! value mode)))))
+          (set-player-repeat! value mode)))
+       (when (member (player-backend-kind value) '(upnp sonos))
+         ;; Replace the renderer's prepared URI when repeat mode changes.
+         (set-network-playback-prepared-index! (player-network value) #f)
+         (set-network-playback-prepared-uri! (player-network value) #f)
+         (prepare-next-network-track! value))))
     ((string=? command "renderer")
      (let* ((id (json-string data 'id #f))
             (selected (and id (renderer-by-id value id))))
@@ -1058,36 +1278,41 @@
               (browse-library library '())
               '()))
          (tab (playlist-tab "default" "Default" '())))
-    (player libraries
-            (remove-duplicates normalized-agent-ids string=?)
-            '()
-            (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)
-            (make-hash)
-            dlna-port)))
+    (define value
+      (player libraries
+              (remove-duplicates normalized-agent-ids string=?)
+              '()
+              (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
+              #f
+              (make-semaphore 1)
+              (make-semaphore 1)
+              (make-hash)
+              (network-playback #f #f #f #f #f #f #f 0 #f)
+              dlna-port))
+    (start-network-monitor! value)
+    value))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Return the complete browser-visible player state.
@@ -1171,8 +1396,10 @@
            (λ (exception)
              (set-error! value (exn-message exception))
              (raise exception))))
-       (perform-command! value command data))
-     (player-state->jsexpr value))))
+       (perform-command! value command data))))
+  ;; State refresh can itself advance a completed network track and therefore
+  ;; acquires command-lock. Take the snapshot after releasing this command.
+  (player-state->jsexpr value))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Discover UPnP renderers and logical Sonos groups asynchronously.
@@ -1403,12 +1630,35 @@
        (with-state-lock
         value
         (λ ()
-          (set-player-closed?! value #t)))))))
+          (set-player-closed?! value #t))))))
+  (let ((monitor (player-network-monitor value)))
+    (when (and monitor (not (thread-dead? monitor)))
+      (kill-thread monitor))
+    (set-player-network-monitor! value #f)))
 
 (module+ test
   (require rackunit
            racket/file)
 
+  (check-eq?
+   (network-stop-decision #t #t #t 6000 #f 1)
+   'requested-stop)
+  (check-eq?
+   (network-stop-decision #f #t #f 1000 #f 0)
+   'wait-for-start)
+  (check-eq?
+   (network-stop-decision #f #t #f 6000 #f 0)
+   'playback-failed)
+  (check-eq?
+   (network-stop-decision #f #t #t 6000 #t 1)
+   'wait-for-next)
+  (check-eq?
+   (network-stop-decision #f #t #t 6000 #t 2)
+   'advance)
+  (check-eq?
+   (network-stop-decision #f #t #t 6000 #f 1)
+   'advance)
+
   (define root
     (make-temporary-file "rkt-web-player-~a" 'directory))
 
@@ -1572,6 +1822,29 @@
          (list (track first-file "First" "Artist" "Album" 60 "audio/flac")
                (track second-file "Second" "Artist" "Album" 60 "audio/flac")))
 
+        (define test-network (player-network example-player))
+        (set-network-playback-prepared-index! test-network 1)
+        (set-network-playback-prepared-uri!
+         test-network
+         "http://renderer.test/next.flac")
+        (check-equal?
+         (network-info-track-index
+          example-player
+          (dlna-info
+           'playing
+           (dlna-track-info second-file "Second" "Artist" "Album"
+                            #f #f #f 60 #f #f #f)
+           "http://renderer.test/current.flac"
+           #f #f 0 60 25 #f #t))
+         1)
+        (check-equal?
+         (network-info-track-index
+          example-player
+          (dlna-info 'playing #f "http://renderer.test/next.flac"
+                     #f #f 0 60 25 #f #t))
+         1)
+        (reset-network-playback! example-player)
+
         (player-command! example-player "play" (hasheq 'index 0))
         (define play-poll
           (player-agent-poll!