Complete refactoring for rktplayer, in order to make it play on DLNA renderers and also use UpNP media server resources.

play/playlist-gui.rkt

@@ -0,0 +1,218 @@
+#lang racket/base
+
+(require racket/class
+         racket-sprintf
+         racket/string
+         racket-webview
+         xml
+         "../misc/utils.rkt")
+
+(provide playlist-gui%)
+
+(define (track-length->string length-seconds)
+  (let* ((whole-seconds
+          (inexact->exact
+           (round length-seconds)))
+         (hours (quotient whole-seconds 3600))
+        (minutes
+         (quotient (remainder whole-seconds 3600)
+                   60))
+        (seconds
+         (remainder (remainder whole-seconds 3600)
+                    60)))
+    (sprintf "%02d:%02d:%02d"
+             hours minutes seconds)))
+
+(define (entry-tooltip entry)
+  (let* ((track (send entry get-track))
+         (uri
+          (and track
+               (send (send track get-resource)
+                     get-uri))))
+    (string-join
+     (filter
+      (lambda (value)
+        (and (string? value)
+             (not (string=? value ""))))
+      (list
+       (send entry get-title)
+       (send entry get-artist)
+       (send entry get-album)
+       uri
+       (and (eq? (send entry get-cache-status)
+                 'failed)
+            (send entry get-cache-error))))
+     "\n")))
+
+(define (track-row playlist track-idx current-track-nr)
+  (let* ((entry (send playlist entry track-idx))
+         (track-id (send playlist track-id track-idx))
+         (row-class
+          (cond
+             ((not (send entry is-valid?))
+              "track invalid")
+             ((not (send entry is-available?))
+              (format "track unavailable ~a"
+                      (send entry get-cache-status)))
+            ((equal? track-idx current-track-nr)
+             "track current")
+            (else "track"))))
+    (list
+     'tr
+      (list (list 'id (format "~a" track-id))
+            (list 'class row-class)
+            (list 'title (entry-tooltip entry))
+            (list 'draggable "true"))
+     (list 'td
+           '((class "number"))
+           (format "~a." (send entry get-number)))
+     (list 'td
+           '((class "title"))
+           (send entry get-title))
+     (list 'td
+           '((class "album"))
+           (send entry get-album))
+     (list 'td
+           '((class "length"))
+           (track-length->string
+            (send entry get-length))))))
+
+(define (playlist->html playlist current-track-nr)
+  (xexpr->string
+   (append
+    (list 'table '((class "tracks")))
+    (for/list ((track-idx
+                (in-range (send playlist length))))
+      (track-row playlist
+                 track-idx
+                 current-track-nr))
+    (list
+     (list 'tr '((class "unresponsive")))))))
+
+(define playlist-gui%
+  (class object%
+    (init-field
+     window
+     element
+     play-track-callback
+     playlist-changed-callback)
+
+    (check/c* playlist-gui%
+              (window object?)
+              (element object?)
+              (play-track-callback procedure?)
+              (playlist-changed-callback procedure?))
+
+    (define dragged-from-idx
+      #f)
+
+    (define/private (row-index playlist element)
+      (send playlist
+            index
+            (send element attr/symbol 'id)))
+
+    (define/private (bind-row-events! playlist)
+      (send window
+            bind!
+            "table.tracks tr.track"
+            '(click contextmenu)
+            (lambda (row event data)
+              (case event
+                ((click)
+                 (let ((track-idx
+                        (row-index playlist row)))
+                    (when (send (send playlist entry track-idx)
+                                is-available?)
+                     (play-track-callback track-idx))))
+                ((contextmenu)
+                 (let* ((track-id (send row id))
+                        (menu
+                         (wv-menu
+                          'track-menu
+                          (wv-menu-item
+                           'm-drop-track
+                           "Drop track"
+                           #:callback
+                           (lambda ()
+                             (send playlist drop-id track-id)
+                             (playlist-changed-callback)))))
+                        (client-x (hash-ref data 'clientX 60))
+                        (client-y (hash-ref data 'clientY 60)))
+                   (send window
+                         popup-menu!
+                         menu
+                         client-x
+                         client-y))))))
+
+      (send window
+            bind!
+            "table.tracks tr.track"
+            'dragstart
+            (lambda (row event data)
+              (set! dragged-from-idx
+                    (row-index playlist row)))
+            #t)
+
+      (send window
+            bind!
+            "table.tracks tr.track"
+            '(dragover drop)
+            (lambda (row event data)
+              (when (eq? event 'drop)
+                (let ((drop-at-idx
+                       (row-index playlist row)))
+                  (when (and (integer? dragged-from-idx)
+                             (integer? drop-at-idx)
+                             (not (= dragged-from-idx
+                                     drop-at-idx)))
+                    (send playlist
+                          move-track
+                          dragged-from-idx
+                          drop-at-idx)
+                    (set! dragged-from-idx #f)
+                    (playlist-changed-callback)))))))
+
+    (define/public (update! playlist current-track-nr)
+      (let ((html
+             (playlist->html playlist
+                             current-track-nr)))
+        (send element set-innerHTML! html)
+        (bind-row-events! playlist)
+        (void)))
+
+    (super-new)))
+
+(module+ test
+  (require rackunit)
+
+  (define test-entry%
+    (class object%
+      (define/public (is-valid?) #t)
+      (define/public (get-number) 3)
+      (define/public (get-title) "Title")
+      (define/public (get-artist) "Artist")
+      (define/public (get-album) "Album")
+      (define/public (get-length) 65)
+      (define/public (get-track) #f)
+      (define/public (get-cache-status) 'available)
+      (define/public (get-cache-error) #f)
+      (define/public (is-available?) #t)
+      (super-new)))
+
+  (define test-playlist%
+    (class object%
+      (define/public (length) 1)
+      (define/public (entry idx)
+        (new test-entry%))
+      (define/public (track-id idx)
+        'track-1)
+      (super-new)))
+
+  (define html
+    (playlist->html (new test-playlist%) 0))
+
+  (check-true (string-contains? html "track current"))
+  (check-true (string-contains? html "draggable"))
+  (check-true (string-contains? html "00:01:05"))
+  (check-equal? (track-length->string 1365.797)
+                "00:22:46"))