play local files to a DLNA Renderer

dlna-player.rkt

@@ -0,0 +1,693 @@
+#lang racket/base
+
+;; Stateful local-file player built on racket-audio metadata and racket-upnp.
+
+(require racket/file
+         racket/path
+         racket/string
+         racket/udp
+         racket-audio/taglib
+         racket-upnp)
+
+(provide make-dlna-player
+         dlna-player?
+         dlna-player-play!
+         dlna-player-set-next-file!
+         dlna-player-pause!
+         dlna-player-resume!
+         dlna-player-stop!
+         dlna-player-seek!
+         dlna-player-seek-percentage!
+         dlna-player-volume!
+         dlna-player-muted!
+         dlna-player-info
+         dlna-player-close!
+         (struct-out dlna-track-info)
+         (struct-out dlna-info))
+
+(struct dlna-track-info
+  (file title artist album genre year track duration
+        sample-rate bit-rate channels)
+  #:transparent)
+
+(struct dlna-info
+  (state track uri next-track next-uri position duration
+         volume muted? reachable?)
+  #:transparent)
+
+(struct publication
+  (track uri metadata)
+  #:transparent)
+
+(struct dlna-player
+  (renderer
+   server
+   poll-seconds
+   volume-poll-seconds
+   transport-lock
+   cache-lock
+   [current #:mutable]
+   [next #:mutable]
+   [cached-info #:mutable]
+   [position-stamp #:mutable]
+   [volume-stamp #:mutable]
+   metadata-cache
+   [counter #:mutable]
+   [running? #:mutable]
+   [poll-thread #:mutable])
+  #:constructor-name make-dlna-player-state)
+
+(define (now-ms)
+  (current-inexact-monotonic-milliseconds))
+
+(define (check-player who player)
+  (unless (dlna-player? player)
+    (raise-argument-error who "dlna-player?" player))
+  (unless (dlna-player-running? player)
+    (raise-arguments-error who "DLNA player has been closed")))
+
+(define (nonempty-string value)
+  (and (string? value)
+       (not (string=? (string-trim value) ""))
+       value))
+
+(define (positive-tag-number value)
+  (and (exact-integer? value)
+       (positive? value)
+       value))
+
+(define (tag-string value)
+  (cond
+    [(string? value) (nonempty-string value)]
+    [(and (list? value) (andmap string? value))
+     (nonempty-string (string-join value " / "))]
+    [else #f]))
+
+(define (file-title path)
+  (let* ([name (path->string (file-name-from-path path))]
+         [without-extension
+          (regexp-replace #px"[.][^.]*$" name "")])
+    (if (string=? without-extension "")
+        name
+        without-extension)))
+
+(define (fallback-track-info path)
+  (dlna-track-info path
+                   (file-title path)
+                   #f
+                   #f
+                   #f
+                   #f
+                   #f
+                   #f
+                   #f
+                   #f
+                   #f))
+
+(define (read-track-info path)
+  (with-handlers ([exn:fail? (lambda (_) (fallback-track-info path))])
+    (call-with-id3-tags
+     path
+     (lambda (tags)
+       (if (tags-valid? tags)
+           (let* ([artist
+                   (or (nonempty-string (tags-artist tags))
+                       (tag-string (tags-album-artist tags)))]
+                  [duration (positive-tag-number (tags-length tags))])
+             (dlna-track-info
+              path
+              (or (nonempty-string (tags-title tags))
+                  (file-title path))
+              artist
+              (nonempty-string (tags-album tags))
+              (nonempty-string (tags-genre tags))
+              (positive-tag-number (tags-year tags))
+              (positive-tag-number (tags-track tags))
+              duration
+              (positive-tag-number (tags-sample-rate tags))
+              (positive-tag-number (tags-bit-rate tags))
+              (positive-tag-number (tags-channels tags))))
+           (fallback-track-info path))))))
+
+(define (track-cache-key path)
+  (list path
+        (file-size path)
+        (file-or-directory-modify-seconds path)))
+
+(define (player-track-info who player file)
+  (unless (path-string? file)
+    (raise-argument-error who "path-string?" file))
+  (let ([path (path->complete-path file)])
+    (unless (file-exists? path)
+      (raise-arguments-error
+       who
+       "audio file does not exist"
+       "file" file))
+    (let* ([key (track-cache-key path)]
+           [cached
+            (call-with-semaphore
+             (dlna-player-cache-lock player)
+             (lambda ()
+               (hash-ref (dlna-player-metadata-cache player) key #f)))])
+      (or cached
+          (let ([info (read-track-info path)])
+            (call-with-semaphore
+             (dlna-player-cache-lock player)
+             (lambda ()
+               (when (>= (hash-count
+                          (dlna-player-metadata-cache player))
+                         128)
+                 (hash-clear! (dlna-player-metadata-cache player)))
+               (hash-set! (dlna-player-metadata-cache player) key info)))
+            info)))))
+
+(define (file-extension path)
+  (let ([match
+         (regexp-match #px"(?i:[.]([a-z0-9]+))$"
+                       (path->string path))])
+    (if match
+        (string-append "." (cadr match))
+        "")))
+
+(define (next-publication-name player path)
+  (call-with-semaphore
+   (dlna-player-cache-lock player)
+   (lambda ()
+     (let ([number (add1 (dlna-player-counter player))])
+       (set-dlna-player-counter! player number)
+       (format "track-~a~a" number (file-extension path))))))
+
+(define (publish-track! player track)
+  (let* ([server (dlna-player-server player)]
+         [uri
+          (media-file-server-publish!
+           server
+           (dlna-track-info-file track)
+           (next-publication-name
+            player
+            (dlna-track-info-file track)))])
+    (with-handlers
+        ([exn:fail?
+          (lambda (exception)
+            (media-file-server-unpublish! server uri)
+            (raise exception))])
+      (publication
+       track
+       uri
+       (media-file-server-didl-lite
+        server
+        uri
+        #:title (dlna-track-info-title track)
+        #:artist (dlna-track-info-artist track)
+        #:album (dlna-track-info-album track)
+        #:genre (dlna-track-info-genre track)
+        #:year (dlna-track-info-year track)
+        #:track (dlna-track-info-track track)
+        #:duration (dlna-track-info-duration track))))))
+
+(define (safe-unpublish! player item)
+  (when item
+    (with-handlers ([exn:fail? (lambda (_) (void))])
+      (media-file-server-unpublish!
+       (dlna-player-server player)
+       (publication-uri item)))))
+
+(define (update-cache! player proc #:position? [position? #f])
+  (call-with-semaphore
+   (dlna-player-cache-lock player)
+   (lambda ()
+     (set-dlna-player-cached-info!
+      player
+      (proc (dlna-player-cached-info player)))
+     (when position?
+       (set-dlna-player-position-stamp! player (now-ms))))))
+
+(define (set-reachable! player reachable?)
+  (update-cache!
+   player
+   (lambda (info)
+     (struct-copy dlna-info info [reachable? reachable?]))))
+
+(define (estimated-info player)
+  (call-with-semaphore
+   (dlna-player-cache-lock player)
+   (lambda ()
+     (let* ([info (dlna-player-cached-info player)]
+            [position (dlna-info-position info)]
+            [duration (dlna-info-duration info)]
+            [elapsed
+             (/ (- (now-ms) (dlna-player-position-stamp player))
+                1000.0)]
+            [estimated
+             (if (and (eq? (dlna-info-state info) 'playing)
+                      (number? position))
+                 (+ position (max 0 elapsed))
+                 position)])
+       (struct-copy
+        dlna-info
+        info
+        [position
+         (if (and (number? duration) (number? estimated))
+             (min duration estimated)
+             estimated)])))))
+
+(define (call-renderer player proc)
+  (check-player 'dlna-player player)
+  (with-handlers
+      ([exn:fail?
+        (lambda (exception)
+          (set-reachable! player #f)
+          (raise exception))])
+    (let ([result
+           (call-with-semaphore
+            (dlna-player-transport-lock player)
+            proc)])
+      (set-reachable! player #t)
+      result)))
+
+(define (promote-or-clear-publications! player uri)
+  (let ([old-current #f]
+        [old-next #f])
+    (when (nonempty-string uri)
+      (call-with-semaphore
+       (dlna-player-cache-lock player)
+       (lambda ()
+         (let ([current (dlna-player-current player)]
+               [next (dlna-player-next player)])
+           (cond
+             [(and next (string=? uri (publication-uri next)))
+              (set! old-current current)
+              (set-dlna-player-current! player next)
+              (set-dlna-player-next! player #f)]
+             [(and current
+                   (not (string=? uri (publication-uri current))))
+              (set! old-current current)
+              (set! old-next next)
+              (set-dlna-player-current! player #f)
+              (set-dlna-player-next! player #f)])))))
+    (safe-unpublish! player old-current)
+    (safe-unpublish! player old-next)))
+
+(define (volume-refresh-due? player)
+  (call-with-semaphore
+   (dlna-player-cache-lock player)
+   (lambda ()
+     (>= (- (now-ms) (dlna-player-volume-stamp player))
+         (* 1000.0 (dlna-player-volume-poll-seconds player))))))
+
+(define (refresh-volume! player #:force? [force? #f])
+  (when (or force? (volume-refresh-due? player))
+    (let ([renderer (dlna-player-renderer player)])
+      (with-handlers ([exn:fail? (lambda (_) (void))])
+        (let ([volume (media-renderer-volume renderer)])
+          (update-cache!
+           player
+           (lambda (info)
+             (struct-copy dlna-info info [volume volume])))))
+      (with-handlers ([exn:fail? (lambda (_) (void))])
+        (let ([muted? (media-renderer-muted? renderer)])
+          (update-cache!
+           player
+           (lambda (info)
+             (struct-copy dlna-info info [muted? muted?])))))
+      (call-with-semaphore
+       (dlna-player-cache-lock player)
+       (lambda ()
+         (set-dlna-player-volume-stamp! player (now-ms)))))))
+
+(define (refresh-player! player #:force-volume? [force-volume? #f])
+  (with-handlers
+      ([exn:fail?
+        (lambda (_)
+          (set-reachable! player #f)
+          #f)])
+    (call-with-semaphore
+     (dlna-player-transport-lock player)
+     (lambda ()
+       (let* ([renderer (dlna-player-renderer player)]
+              [state (media-renderer-status renderer)]
+              [position
+               (with-handlers ([exn:fail? (lambda (_) #f)])
+                 (media-renderer-position renderer))]
+              [uri (and position (transport-position-uri position))]
+              [seconds
+               (and position (transport-position-seconds position))]
+              [renderer-duration
+               (and position
+                    (transport-position-duration position))])
+         (promote-or-clear-publications! player uri)
+         (let* ([current (dlna-player-current player)]
+                [next (dlna-player-next player)]
+                [track (and current (publication-track current))]
+                [track-duration
+                 (and track (dlna-track-info-duration track))]
+                [duration
+                 (if (and (number? renderer-duration)
+                          (positive? renderer-duration))
+                     renderer-duration
+                     track-duration)])
+           (update-cache!
+            player
+            (lambda (info)
+              (struct-copy
+               dlna-info
+               info
+               [state state]
+               [track track]
+               [uri (or (nonempty-string uri)
+                        (and current (publication-uri current)))]
+               [next-track (and next (publication-track next))]
+               [next-uri (and next (publication-uri next))]
+               [position (if (number? seconds)
+                             seconds
+                             (dlna-info-position info))]
+               [duration duration]
+               [reachable? #t]))
+            #:position? #t))
+         (refresh-volume! player #:force? force-volume?)
+         #t)))))
+
+(define (poll-player player)
+  (let loop ()
+    (when (dlna-player-running? player)
+      (sleep (dlna-player-poll-seconds player))
+      (when (dlna-player-running? player)
+        (refresh-player! player)
+        (loop)))))
+
+(define (renderer-local-address renderer)
+  (let ([socket (udp-open-socket)])
+    (dynamic-wind
+      void
+      (lambda ()
+        (udp-connect! socket (media-renderer-address renderer) 1900)
+        (let-values ([(local-host _local-port
+                                 _remote-host _remote-port)
+                      (udp-addresses socket #t)])
+          local-host))
+      (lambda ()
+        (udp-close socket)))))
+
+(define (server-base-url listen-ip port path)
+  (unless (and (exact-integer? port) (<= 1 port 65535))
+    (raise-argument-error 'make-dlna-player
+                          "exact-integer? between 1 and 65535"
+                          port))
+  (unless (string? path)
+    (raise-argument-error 'make-dlna-player "string?" path))
+  (let* ([with-leading
+          (if (string-prefix? path "/")
+              path
+              (string-append "/" path))]
+         [normalized
+          (if (string-suffix? with-leading "/")
+              with-leading
+              (string-append with-leading "/"))])
+    (format "http://~a:~a~a" listen-ip port normalized)))
+
+(define (make-dlna-player renderer
+                          #:listen-ip [listen-ip #f]
+                          #:port [port 8080]
+                          #:path [path "/racket-audio-dlna/"]
+                          #:poll-seconds [poll-seconds 1.0]
+                          #:volume-poll-seconds
+                          [volume-poll-seconds 5.0])
+  (unless (media-renderer? renderer)
+    (raise-argument-error 'make-dlna-player "media-renderer?" renderer))
+  (unless (or (not listen-ip) (string? listen-ip))
+    (raise-argument-error 'make-dlna-player
+                          "(or/c #f string?)"
+                          listen-ip))
+  (unless (and (rational? poll-seconds) (positive? poll-seconds))
+    (raise-argument-error 'make-dlna-player
+                          "positive-real?"
+                          poll-seconds))
+  (unless (and (rational? volume-poll-seconds)
+               (positive? volume-poll-seconds))
+    (raise-argument-error 'make-dlna-player
+                          "positive-real?"
+                          volume-poll-seconds))
+  (let* ([local-address
+          (or listen-ip (renderer-local-address renderer))]
+         [server
+          (start-media-file-server
+           (server-base-url local-address port path)
+           #:listen-ip local-address)]
+         [player
+          (make-dlna-player-state
+           renderer
+           server
+           poll-seconds
+           volume-poll-seconds
+           (make-semaphore 1)
+           (make-semaphore 1)
+           #f
+           #f
+           (dlna-info 'unknown #f #f #f #f
+                      0 #f #f #f #f)
+           (now-ms)
+           0
+           (make-hash)
+           0
+           #t
+           #f)])
+    (refresh-player! player #:force-volume? #t)
+    (set-dlna-player-poll-thread!
+     player
+     (thread (lambda () (poll-player player))))
+    player))
+
+(define (dlna-player-play! player file)
+  (check-player 'dlna-player-play! player)
+  (let* ([track (player-track-info 'dlna-player-play! player file)]
+         [item (publish-track! player track)])
+    (with-handlers
+        ([exn:fail?
+          (lambda (exception)
+            (safe-unpublish! player item)
+            (raise exception))])
+      (call-renderer
+       player
+       (lambda ()
+         (media-renderer-play-uri!
+          (dlna-player-renderer player)
+          (publication-uri item)
+          #:metadata (publication-metadata item))))
+      (let ([old-current #f]
+            [old-next #f])
+        (call-with-semaphore
+         (dlna-player-cache-lock player)
+         (lambda ()
+           (set! old-current (dlna-player-current player))
+           (set! old-next (dlna-player-next player))
+           (set-dlna-player-current! player item)
+           (set-dlna-player-next! player #f)
+           (set-dlna-player-cached-info!
+            player
+            (dlna-info
+             'playing
+             track
+             (publication-uri item)
+             #f
+             #f
+             0
+             (dlna-track-info-duration track)
+             (dlna-info-volume (dlna-player-cached-info player))
+             (dlna-info-muted? (dlna-player-cached-info player))
+             #t))
+           (set-dlna-player-position-stamp! player (now-ms))))
+        (safe-unpublish! player old-current)
+        (safe-unpublish! player old-next))
+      (void))))
+
+(define (dlna-player-set-next-file! player file)
+  (check-player 'dlna-player-set-next-file! player)
+  (let* ([track
+          (player-track-info
+           'dlna-player-set-next-file!
+           player
+           file)]
+         [item (publish-track! player track)])
+    (with-handlers
+        ([exn:fail?
+          (lambda (exception)
+            (safe-unpublish! player item)
+            (raise exception))])
+      (call-renderer
+       player
+       (lambda ()
+         (media-renderer-set-next-uri!
+          (dlna-player-renderer player)
+          (publication-uri item)
+          #:metadata (publication-metadata item))))
+      (let ([old-next #f])
+        (call-with-semaphore
+         (dlna-player-cache-lock player)
+         (lambda ()
+           (set! old-next (dlna-player-next player))
+           (set-dlna-player-next! player item)
+           (set-dlna-player-cached-info!
+            player
+            (struct-copy
+             dlna-info
+             (dlna-player-cached-info player)
+             [next-track track]
+             [next-uri (publication-uri item)]))))
+        (safe-unpublish! player old-next))
+      (void))))
+
+(define (dlna-player-pause! player)
+  (check-player 'dlna-player-pause! player)
+  (let ([position (dlna-info-position (estimated-info player))])
+    (call-renderer
+     player
+     (lambda ()
+       (media-renderer-pause! (dlna-player-renderer player))))
+    (update-cache!
+     player
+     (lambda (info)
+       (struct-copy dlna-info
+                    info
+                    [state 'paused]
+                    [position position]))
+     #:position? #t)
+    (void)))
+
+(define (dlna-player-resume! player)
+  (check-player 'dlna-player-resume! player)
+  (call-renderer
+   player
+   (lambda ()
+     (media-renderer-play! (dlna-player-renderer player))))
+  (update-cache!
+   player
+   (lambda (info)
+     (struct-copy dlna-info info [state 'playing]))
+   #:position? #t)
+  (void))
+
+(define (dlna-player-stop! player)
+  (check-player 'dlna-player-stop! player)
+  (call-renderer
+   player
+   (lambda ()
+     (media-renderer-stop! (dlna-player-renderer player))))
+  (update-cache!
+   player
+   (lambda (info)
+     (struct-copy dlna-info
+                  info
+                  [state 'stopped]
+                  [position 0]))
+   #:position? #t)
+  (void))
+
+(define (dlna-player-seek! player seconds)
+  (check-player 'dlna-player-seek! player)
+  (unless (and (rational? seconds) (not (negative? seconds)))
+    (raise-argument-error 'dlna-player-seek!
+                          "nonnegative-real?"
+                          seconds))
+  (call-renderer
+   player
+   (lambda ()
+     (media-renderer-seek!
+      (dlna-player-renderer player)
+      seconds)))
+  (update-cache!
+   player
+   (lambda (info)
+     (struct-copy dlna-info info [position seconds]))
+   #:position? #t)
+  (void))
+
+(define (dlna-player-seek-percentage! player percentage)
+  (check-player 'dlna-player-seek-percentage! player)
+  (unless (rational? percentage)
+    (raise-argument-error 'dlna-player-seek-percentage!
+                          "real?"
+                          percentage))
+  (let* ([initial (dlna-player-info player)]
+         [info
+          (if (number? (dlna-info-duration initial))
+              initial
+              (dlna-player-info player #:refresh? #t))]
+         [duration (dlna-info-duration info)])
+    (unless (and (number? duration) (positive? duration))
+      (raise-arguments-error
+       'dlna-player-seek-percentage!
+       "track duration is not available"))
+    (dlna-player-seek!
+     player
+     (* duration (/ (min 100 (max 0 percentage)) 100.0)))))
+
+(define (dlna-player-volume! player percentage)
+  (check-player 'dlna-player-volume! player)
+  (unless (rational? percentage)
+    (raise-argument-error 'dlna-player-volume! "real?" percentage))
+  (let ([volume
+         (min 100
+              (max 0
+                   (inexact->exact (round percentage))))])
+    (call-renderer
+     player
+     (lambda ()
+       (media-renderer-set-volume!
+        (dlna-player-renderer player)
+        volume)))
+    (update-cache!
+     player
+     (lambda (info)
+       (struct-copy dlna-info info [volume volume])))
+    (call-with-semaphore
+     (dlna-player-cache-lock player)
+     (lambda ()
+       (set-dlna-player-volume-stamp! player (now-ms))))
+    (void)))
+
+(define (dlna-player-muted! player muted?)
+  (check-player 'dlna-player-muted! player)
+  (unless (boolean? muted?)
+    (raise-argument-error 'dlna-player-muted! "boolean?" muted?))
+  (call-renderer
+   player
+   (lambda ()
+     (media-renderer-set-muted!
+      (dlna-player-renderer player)
+      muted?)))
+  (update-cache!
+   player
+   (lambda (info)
+     (struct-copy dlna-info info [muted? muted?])))
+  (void))
+
+(define (dlna-player-info player #:refresh? [refresh? #f])
+  (check-player 'dlna-player-info player)
+  (unless (boolean? refresh?)
+    (raise-argument-error 'dlna-player-info "boolean?" refresh?))
+  (when refresh?
+    (refresh-player! player #:force-volume? #t))
+  (estimated-info player))
+
+(define (dlna-player-close! player)
+  (unless (dlna-player? player)
+    (raise-argument-error 'dlna-player-close! "dlna-player?" player))
+  (when (dlna-player-running? player)
+    (set-dlna-player-running?! player #f)
+    (let ([poll-thread (dlna-player-poll-thread player)])
+      (when poll-thread
+        (kill-thread poll-thread)
+        (set-dlna-player-poll-thread! player #f)))
+    (with-handlers ([exn:fail? (lambda (_) (void))])
+      (call-with-semaphore
+       (dlna-player-transport-lock player)
+       (lambda ()
+         (media-renderer-stop! (dlna-player-renderer player)))))
+    (let ([current (dlna-player-current player)]
+          [next (dlna-player-next player)])
+      (safe-unpublish! player current)
+      (safe-unpublish! player next)
+      (set-dlna-player-current! player #f)
+      (set-dlna-player-next! player #f))
+    (media-file-server-stop! (dlna-player-server player)))
+  (void))