dlna

dlna-player.rkt

@@ -0,0 +1,244 @@
+#lang racket
+
+(require racket/class
+         racket/path
+         racket/udp
+         racket-upnp
+         "utils.rkt")
+
+(provide dlna-player%)
+
+(define dlna-player%
+  (class object%
+    (init-field renderer
+                [port 8080]
+                [time-updater (lambda (time-s length-s) #t)]
+                [track-nr-updater (lambda (nr) #t)]
+                [state-updater (lambda (state) #t)]
+                [track-ended (lambda () #t)]
+                [track-changed (lambda (nr) #t)])
+
+    (define lock (make-semaphore 1))
+    (define server #f)
+    (define poll-thread #f)
+    (define stopped #f)
+    (define requested-stop #t)
+    (define current-state 'stopped)
+    (define current-track-nr #f)
+    (define current-duration 0)
+    (define uri->track-nr (make-hash))
+
+    (define (with-renderer f)
+      (call-with-semaphore lock f))
+
+    (define (local-address)
+      (let ((socket (udp-open-socket)))
+        (dynamic-wind
+          void
+          (lambda ()
+            (udp-connect! socket (media-renderer-address renderer) 1900)
+            (let-values (((address local-port remote-address remote-port)
+                          (udp-addresses socket #t)))
+              address))
+          (lambda ()
+            (udp-close socket)))))
+
+    (define (start-server)
+      (let ((address (local-address)))
+        (info-rktplayer
+         "Starting DLNA media server on ~a:~a for ~a"
+         address
+         port
+         (media-renderer-name renderer))
+        (start-media-file-server
+         (format "http://~a:~a/media/" address port)
+         #:listen-ip address)))
+
+    (define (file-url file track-nr)
+      (let* ((extension (path-get-extension file))
+             (name (if extension
+                       (format "track-~a~a" track-nr extension)
+                       (format "track-~a" track-nr)))
+             (uri (media-file-server-publish! server file name)))
+        (hash-set! uri->track-nr uri track-nr)
+        uri))
+
+    (define (renderer-call what f)
+      (with-handlers
+        ((exn:fail?
+          (lambda (exception)
+            (warn-rktplayer
+             "Could not ~a on DLNA renderer ~a: ~a"
+             what
+             (media-renderer-name renderer)
+             (exn-message exception))
+            #f)))
+        (with-renderer f)))
+
+    (define (update-track uri)
+      (let ((nr (and uri (hash-ref uri->track-nr uri #f))))
+        (when (and nr
+                   (or (not current-track-nr)
+                       (not (= nr current-track-nr))))
+          (set! current-track-nr nr)
+          (track-nr-updater nr)
+          (track-changed nr))))
+
+    (define (poll)
+      (let ((reported-state
+             (renderer-call
+              "read playback state"
+              (lambda ()
+                (media-renderer-status renderer)))))
+        (when reported-state
+          (let ((state (if (eq? reported-state 'no-media)
+                           'stopped
+                           reported-state)))
+          (unless (eq? state current-state)
+            (set! current-state state)
+            (state-updater state))
+          (when (or (eq? state 'playing)
+                    (eq? state 'paused)
+                    (eq? state 'transitioning))
+            (let ((position
+                   (renderer-call
+                    "read playback position"
+                    (lambda ()
+                      (media-renderer-position renderer)))))
+              (when position
+                (let ((seconds (transport-position-seconds position))
+                      (duration (transport-position-duration position)))
+                  (when (and seconds duration)
+                    (set! current-duration duration)
+                    (time-updater seconds duration))
+                  (update-track (transport-position-uri position))))))
+          (when (and (eq? state 'stopped)
+                     (not requested-stop))
+            (set! requested-stop #t)
+            (track-ended))))))
+
+    (define (poll-loop)
+      (let loop ()
+        (unless stopped
+          (with-handlers
+            ((exn:fail?
+              (lambda (exception)
+                (warn-rktplayer
+                 "DLNA polling failed for ~a: ~a"
+                 (media-renderer-name renderer)
+                 (exn-message exception)))))
+            (poll))
+          (sleep 0.5)
+          (loop))))
+
+    (define/public (name)
+      (media-renderer-name renderer))
+
+    (define/public (next-uri-supported?)
+      (and (renderer-call
+            "inspect supported actions"
+            (lambda ()
+              (media-renderer-next-uri-supported? renderer)))
+           #t))
+
+    (define/public (play-file! file track-nr
+                               #:next-file (next-file #f)
+                               #:next-track-nr (next-track-nr #f))
+      (let ((uri (file-url file track-nr))
+            (next-uri (and next-file
+                           next-track-nr
+                           (file-url next-file next-track-nr))))
+        (set! requested-stop #f)
+        (set! current-track-nr track-nr)
+        (track-nr-updater track-nr)
+        (state-updater 'transitioning)
+        (if next-uri
+            (with-renderer
+             (lambda ()
+               (media-renderer-play-uri!
+                renderer
+                uri
+                #:next-uri next-uri)))
+            (with-renderer
+             (lambda ()
+               (media-renderer-play-uri! renderer uri))))))
+
+    (define/public (set-next-file! file track-nr)
+      (let ((uri (file-url file track-nr)))
+        (with-renderer
+         (lambda ()
+           (media-renderer-set-next-uri! renderer uri)))))
+
+    (define/public (clear-next!)
+      (with-renderer
+       (lambda ()
+         (media-renderer-set-next-uri! renderer ""))))
+
+    (define/public (pause!)
+      (with-renderer
+       (lambda ()
+         (media-renderer-pause! renderer))))
+
+    (define/public (play!)
+      (with-renderer
+       (lambda ()
+         (media-renderer-play! renderer))))
+
+    (define/public (stop!)
+      (set! requested-stop #t)
+      (with-renderer
+       (lambda ()
+         (media-renderer-stop! renderer))))
+
+    (define/public (seek! percentage)
+      (when (> current-duration 0)
+        (with-renderer
+         (lambda ()
+           (media-renderer-seek!
+            renderer
+            (* current-duration (/ percentage 100.0)))))))
+
+    (define/public (volume)
+      (or (renderer-call
+           "read volume"
+           (lambda ()
+             (media-renderer-volume renderer)))
+          0))
+
+    (define/public (set-volume! percentage)
+      (renderer-call
+       "set volume"
+       (lambda ()
+         (media-renderer-set-volume!
+          renderer
+          (max 0
+               (min 100
+                    (inexact->exact
+                     (round percentage))))))))
+
+    (define/public (quit)
+      (set! requested-stop #t)
+      (set! stopped #t)
+      (when poll-thread
+        (kill-thread poll-thread))
+      (with-handlers
+        ((exn:fail?
+          (lambda (exception)
+            (dbg-rktplayer
+             "Could not stop DLNA renderer while quitting: ~a"
+             (exn-message exception)))))
+        (with-renderer
+         (lambda ()
+           (media-renderer-stop! renderer))))
+      (when server
+        (media-file-server-stop! server)
+        (set! server #f)))
+
+    (super-new)
+
+    (begin
+      (set! server (start-server))
+      (set! poll-thread (thread poll-loop))
+      (info-rktplayer
+       "DLNA player initialized for ~a"
+       (media-renderer-name renderer)))))