Files

694 lines
22 KiB
Racket

#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))