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

2026-08-08 14:29:01 +02:00
parent 186b3bb8d7
commit f5fdc38e67
69 changed files with 5953 additions and 1647 deletions
@@ -0,0 +1,191 @@
+#lang racket/base
+
+(require net/url
+         racket-mimetypes/mimetypes
+         racket/class
+         racket/list
+         racket/port
+         racket/string
+         (prefix-in upnp: racket-upnp)
+         "base/booklet-provider.rkt"
+         "base/image-provider.rkt"
+         "library-ref.rkt"
+         "base/media-resource.rkt"
+         "base/tag-data-provider.rkt"
+         "track-tag-data.rkt"
+         "base/track.rkt"
+         "../misc/utils.rkt")
+
+(provide track-media-server%)
+
+(define tag-data-provider-media-server%
+  (class tag-data-provider%
+    (init-field
+     entry
+     resource)
+
+    (define/override (get-tag-data)
+      (let ((artists
+             (upnp:media-item-artists entry)))
+        (track-tag-data
+         (upnp:media-entry-title entry)
+         (cond
+           ((not (null? artists))
+            (car artists))
+           ((upnp:media-item-creator entry)
+            (upnp:media-item-creator entry))
+           (else ""))
+         (or (upnp:media-item-album entry)
+             "")
+         (or
+          (upnp:media-item-original-track-number
+           entry)
+          0)
+         (or (upnp:media-resource-duration
+              resource)
+             0))))
+
+    (super-new)))
+
+(define image-provider-media-server%
+  (class image-provider%
+    (init-field uri)
+
+    (define mime-type
+      (and uri
+           (mimetype-for-ext
+            (regexp-replace
+             #px"[?#].*$"
+             uri
+             "")
+            #:default
+            "application/octet-stream")))
+
+    (define/private (stored-file target-file)
+      (let ((extension
+             (cond
+               ((equal? mime-type "image/jpeg") ".jpg")
+               ((equal? mime-type "image/png") ".png")
+               (else ""))))
+        (string-append
+         (format "~a" target-file)
+         extension)))
+
+    (define/override (has-image?)
+      (and (string? uri)
+           (not (string=? uri ""))))
+
+    (define/override (image->file target-file)
+      (and
+       (send this has-image?)
+       (with-handlers
+           ((exn:fail?
+             (lambda (exception)
+               (warn-rktplayer
+                "Could not retrieve media-server image: ~a"
+                (exn-message exception))
+               #f)))
+         (let ((file (stored-file target-file)))
+           (call/input-url
+            (string->url uri)
+            get-pure-port
+            (lambda (input)
+              (call-with-output-file
+               file
+               (lambda (output)
+                 (copy-port input output))
+               #:exists 'replace)))
+           file))))
+
+    (define/override (image->mimetype)
+      (or mime-type
+          'no-mimetype))
+
+    (super-new)))
+
+(define booklet-provider-media-server%
+  (class booklet-provider%
+    (define/override (has-booklet?)
+      #f)
+
+    (define/override (booklet-file)
+      #f)
+
+    (super-new)))
+
+(define (audio-resource? resource)
+  (let ((content-type
+         (upnp:media-resource-content-type
+          resource)))
+    (and content-type
+         (string-prefix?
+          content-type
+          "audio/"))))
+
+(define (resource-seekable? resource)
+  (let ((protocol-info
+         (upnp:media-resource-protocol-info
+          resource)))
+    (and protocol-info
+         (regexp-match?
+          #px"DLNA[.]ORG_OP=(?:01|10|11)"
+          protocol-info))))
+
+(define track-media-server%
+  (class track%
+    (init-field
+     library
+     entry)
+
+    (check/c track-media-server%
+             entry
+             upnp:media-item?)
+
+    (define source-resource
+      (or
+       (findf
+        audio-resource?
+        (upnp:media-item-resources entry))
+       (car
+        (upnp:media-item-resources entry))))
+
+    (define resource
+      (new media-resource%
+           [uri
+            (upnp:media-resource-uri
+             source-resource)]
+           [mime-type
+            (upnp:media-resource-content-type
+             source-resource)]
+           [protocol-info
+            (upnp:media-resource-protocol-info
+             source-resource)]
+           [seekable?
+            (resource-seekable?
+             source-resource)]))
+
+    (super-new
+     [resource resource]
+     [music-library-factory-id
+      (let ((cfg (send library get-cfg)))
+        (library-ref
+         (send cfg get-id)
+         (send cfg get-kind)
+         (send cfg get-kind-version)))]
+     [track-factory-id
+      'media-server-item]
+     [track-relive-info
+      (list
+       (upnp:media-entry-parent-id entry)
+       (upnp:media-entry-id entry))]
+     [tag-data-provider
+      (new tag-data-provider-media-server%
+           [entry entry]
+           [resource source-resource])]
+     [image-provider
+      (new image-provider-media-server%
+           [uri
+            (upnp:media-item-album-art-uri
+             entry)])]
+     [booklet-provider
+      (new booklet-provider-media-server%)])))