shared media servers

dlna-player.rkt

@@ -47,6 +47,8 @@
 (struct dlna-player
   (renderer
    server
+   owns-server?
+   publication-prefix
    poll-seconds
    volume-poll-seconds
    transport-lock
@@ -186,7 +188,10 @@
    (lambda ()
      (let ([number (add1 (dlna-player-counter player))])
        (set-dlna-player-counter! player number)
-       (format "track-~a~a" number (file-extension path))))))
+       (format "~atrack-~a~a"
+               (dlna-player-publication-prefix player)
+               number
+               (file-extension path))))))
 
 (define (publish-track! player track)
   (dbg-dlna-player "Publishing track file=~a title=~a" (dlna-track-info-file track) (dlna-track-info-title track))
@@ -438,7 +443,18 @@
               (string-append with-leading "/"))])
     (format "http://~a:~a~a" listen-ip port normalized)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Create a stateful audio player for one DLNA media renderer.
+; pre    : Renderer is a media renderer, media-file-server is #f or a running
+;          media file server, and the polling values are positive rationals.
+; post   : A private media server is started only when no shared server was
+;          supplied; transport polling starts immediately.
+; result : A running DLNA player. A shared server remains owned by its caller.
+; internals: Players using a shared server receive distinct publication paths
+;            so their independently numbered track URLs cannot collide.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define (make-dlna-player renderer
+                          #:media-file-server [file-server #f]
                           #:listen-ip [listen-ip #f]
                           #:port [port 8080]
                           #:path [path "/racket-audio-dlna/"]
@@ -447,6 +463,10 @@
                           [volume-poll-seconds 5.0])
   (unless (media-renderer? renderer)
     (raise-argument-error 'make-dlna-player "media-renderer?" renderer))
+  (unless (or (not file-server) (media-file-server? file-server))
+    (raise-argument-error 'make-dlna-player
+                          "(or/c #f media-file-server?)"
+                          file-server))
   (unless (or (not listen-ip) (string? listen-ip))
     (raise-argument-error 'make-dlna-player
                           "(or/c #f string?)"
@@ -461,16 +481,27 @@
                           "positive-real?"
                           volume-poll-seconds))
   (let* ([local-address
-          (or listen-ip (renderer-local-address renderer))]
+          (and (not file-server)
-         [_ (info-dlna-player "Creating DLNA player renderer=~a address=~a listen-ip=~a port=~a path=~a" (media-renderer-name renderer) (media-renderer-address renderer) local-address port path)]
+               (or listen-ip (renderer-local-address renderer)))]
          [server
+          (or file-server
               (start-media-file-server
                (server-base-url local-address port path)
-           #:listen-ip local-address)]
+               #:listen-ip local-address))]
+         [_ (info-dlna-player
+             "Creating DLNA player renderer=~a address=~a media-url=~a shared-server=~a"
+             (media-renderer-name renderer)
+             (media-renderer-address renderer)
+             (media-file-server-url server)
+             (and file-server #t))]
          [player
           (make-dlna-player-state
            renderer
            server
+           (not file-server)
+           (if file-server
+               (format "~a/" (gensym 'player))
+               "")
            poll-seconds
            volume-poll-seconds
            (make-semaphore 1)
@@ -835,6 +866,14 @@
     (refresh-player! player #:force-volume? #t))
   (estimated-info player))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Stop playback and release all resources owned by a DLNA player.
+; pre    : Player is a dlna-player.
+; post   : Polling and renderer playback are stopped, owned publications are
+;          removed, and a privately created media server is stopped. A shared
+;          media server remains running.
+; result : Void; closing an already closed player has no effect.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define (dlna-player-close! player)
   (unless (dlna-player? player)
     (raise-argument-error 'dlna-player-close! "dlna-player?" player))
@@ -856,5 +895,6 @@
       (safe-unpublish! player next)
       (set-dlna-player-current! player #f)
       (set-dlna-player-next! player #f))
-    (media-file-server-stop! (dlna-player-server player)))
+    (when (dlna-player-owns-server? player)
+      (media-file-server-stop! (dlna-player-server player))))
   (void))

info.rkt

@@ -1,7 +1,7 @@
 #lang info
 
 (define pkg-authors '(hnmdijkema))
-(define version "0.1.2")
+(define version "0.1.3")
 (define license 'GPL-2.0-or-later)
 (define collection "racket-audio-dlna")
 (define pkg-desc
@@ -24,4 +24,3 @@
 
 (define test-omit-paths 'all)
 
-

scribblings/racket-audio-dlna.scrbl

@@ -5,6 +5,7 @@
    racket/base
    racket/contract
    racket-audio-dlna
+   racket-upnp/media-file-server
    racket-upnp/media-renderer))
 
 @title{racket-audio-dlna}
@@ -21,6 +22,8 @@ control.
 
 @defproc[(make-dlna-player
           [renderer media-renderer?]
+          [#:media-file-server file-server
+           (or/c #f media-file-server?) #f]
           [#:listen-ip listen-ip (or/c #f string?) #f]
           [#:port port exact-integer? 8080]
           [#:path path string? "/racket-audio-dlna/"]
@@ -29,9 +32,15 @@ control.
            volume-poll-seconds (and/c rational? positive?) 5.0])
          dlna-player?]{
 
-Creates a player for @racket[renderer] and starts its local HTTP media server.
+Creates a player for @racket[renderer]. When @racket[file-server] is
-When @racket[listen-ip] is @racket[#f], the address is selected from the
+@racket[#f], the player starts and owns a local HTTP media server. When a
-network route to the renderer.
+@racket[media-file-server?] is supplied, the player publishes through that
+shared server in an automatically generated private path. Closing the player
+removes its publications but does not stop the shared server.
+
+The @racket[listen-ip], @racket[port], and @racket[path] arguments configure
+only a media server created by the player. When @racket[listen-ip] is
+@racket[#f], the address is selected from the network route to the renderer.
 
 The player polls transport state and position every @racket[poll-seconds].
 Volume and mute state are refreshed every @racket[volume-poll-seconds].
@@ -194,8 +203,10 @@ Changing the file therefore invalidates its cached metadata.
 
 @defproc[(dlna-player-close! [player dlna-player?]) void?]{
 
-Stops playback, removes current and next publications, stops the HTTP server,
+Stops playback, removes current and next publications, and terminates the
-and terminates the polling thread.  Repeated calls have no effect.
+polling thread. A media server created by the player is also stopped. A shared
+server supplied to @racket[make-dlna-player] remains running. Repeated calls
+have no effect.
 }
 
 @section{Example}

tests/interface-test.rkt

@@ -41,5 +41,9 @@
 (check-true (procedure? dlna-player-play-uri!))
 (check-true (procedure? dlna-player-set-next-uri!))
 
+(define-values (_required-keywords accepted-keywords)
+  (procedure-keywords make-dlna-player))
+(check-not-false (member '#:media-file-server accepted-keywords))
+
 (check-exn exn:fail:contract?
            (lambda () (make-dlna-player #f)))

tests/shared-media-server-test.rkt

@@ -0,0 +1,84 @@
+#lang racket/base
+
+(require rackunit
+         racket/file
+         racket/tcp
+         racket-upnp
+         racket-upnp/private/model
+         "../main.rkt")
+
+(define (available-port)
+  (let ((listener (tcp-listen 0 4 #t "127.0.0.1")))
+    (let-values (((_local-host port _remote-host _remote-port)
+                  (tcp-addresses listener #t)))
+      (tcp-close listener)
+      port)))
+
+(define (test-renderer id)
+  (upnp-device
+   id
+   "urn:schemas-upnp-org:device:MediaRenderer:1"
+   "Test renderer"
+   "Test"
+   "Test"
+   "1"
+   #f
+   "http://127.0.0.1/device.xml"
+   "127.0.0.1"
+   #f
+   '()
+   '()
+   (hash)))
+
+(define port (available-port))
+(define file (make-temporary-file "racket-audio-dlna-shared-~a.flac"))
+(define server #f)
+(define first-player #f)
+(define second-player #f)
+
+(dynamic-wind
+  (λ ()
+    (call-with-output-file
+     file
+     #:exists 'truncate
+     (λ (output)
+       (write-bytes #"test audio" output)))
+    (set! server
+          (start-media-file-server
+           (format "http://127.0.0.1:~a/media/" port)
+           #:listen-ip "127.0.0.1"))
+    (set! first-player
+          (make-dlna-player
+           (test-renderer "uuid:first")
+           #:media-file-server server
+           #:listen-ip "127.0.0.1"
+           #:poll-seconds 60))
+    (set! second-player
+          (make-dlna-player
+           (test-renderer "uuid:second")
+           #:media-file-server server
+           #:listen-ip "127.0.0.1"
+           #:poll-seconds 60)))
+  (λ ()
+    (dlna-player-close! first-player)
+    (set! first-player #f)
+    (define first-uri
+      (media-file-server-publish! server file "after-first.flac"))
+    (check-true (string? first-uri))
+    (media-file-server-unpublish! server first-uri)
+
+    (dlna-player-close! second-player)
+    (set! second-player #f)
+    (define second-uri
+      (media-file-server-publish! server file "after-second.flac"))
+    (check-true (string? second-uri))
+    (media-file-server-unpublish! server second-uri))
+  (λ ()
+    (when first-player
+      (dlna-player-close! first-player))
+    (when second-player
+      (dlna-player-close! second-player))
+    (when server
+      (media-file-server-stop! server))
+    (when (file-exists? file)
+      (delete-file file))))