Complete refactoring for rktplayer, in order to make it play on DLNA renderers and also use UpNP media server resources.
This commit is contained in:
@@ -0,0 +1,261 @@
|
||||
#lang racket
|
||||
|
||||
(require racket/class
|
||||
racket-audio
|
||||
"../../misc/utils.rkt"
|
||||
"../../library/base/media-resource.rkt"
|
||||
lru-cache
|
||||
)
|
||||
|
||||
(provide player%)
|
||||
|
||||
(define player%
|
||||
(class object%
|
||||
(init-field [settings #f]
|
||||
[time-updater (λ (time-s length-s) #t)]
|
||||
[track-nr-updater (λ (nr) #t)]
|
||||
[state-updater (λ (state) #t)]
|
||||
[repeat-updater (λ (state) #t)]
|
||||
[audio-info-cb (λ (current-sample rate channels bits kind) #t)]
|
||||
[buffer-max-seconds 10]
|
||||
[buffer-min-seconds 4]
|
||||
)
|
||||
|
||||
(define player-kind 'local)
|
||||
(define player-host #f)
|
||||
(define player-basepaths #f)
|
||||
|
||||
(define player #f)
|
||||
(define playlist #f)
|
||||
(define state 'stopped)
|
||||
(define repeat 'no-repeat)
|
||||
|
||||
(define full-state (make-hash))
|
||||
(define music-id -1)
|
||||
(define track-cache (make-lru 10
|
||||
#:cmp (λ (a b) (= (car a) (car b)))))
|
||||
|
||||
|
||||
(define (music-id->track-nr id)
|
||||
(let ((item (lru-use track-cache (list music-id) #f)))
|
||||
(if (eq? item #f)
|
||||
#f
|
||||
(cadr item))))
|
||||
|
||||
(define (register-music-id&track-nr id track-nr)
|
||||
(lru-add! track-cache (list id track-nr)))
|
||||
|
||||
(define (clear-music-ids!)
|
||||
(lru-clear track-cache))
|
||||
|
||||
|
||||
;;(define x 0)
|
||||
(define (audio-state-cb handle player-state st*)
|
||||
(set! full-state st*)
|
||||
;;(when (< x 5)
|
||||
;; (displayln st*)
|
||||
;; (set! x (+ x 1)))
|
||||
(unless (or (not (eq? player handle)) (eq? player #f))
|
||||
(let ((st (audio-state player)))
|
||||
(when (or (eq? st 'paused) (eq? st 'playing))
|
||||
(time-updater (audio-at-second player)
|
||||
(audio-duration player))
|
||||
(when (not (= music-id (audio-music-id player)))
|
||||
(set! music-id (audio-music-id player))
|
||||
(let ((track-nr (music-id->track-nr music-id)))
|
||||
(if (eq? track-nr #f)
|
||||
(warn-rktplayer "Unexpected: no track-nr for given music-id")
|
||||
(track-nr-updater track-nr))))
|
||||
)
|
||||
(state-updater st)
|
||||
(repeat-updater repeat)
|
||||
(if (or (eq? player-state 'quit) (eq? player-state 'stopped))
|
||||
(audio-info-cb 0 0 0 'none)
|
||||
(audio-info-cb (audio-rate player) (audio-channels player)
|
||||
(audio-bits player) (audio-decoder player)))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define (on-eof-stream-cb handle)
|
||||
(when (and (eq? player handle) (not (eq? player #f)))
|
||||
(let ((track-nr (music-id->track-nr music-id)))
|
||||
(send this next))))
|
||||
|
||||
|
||||
;(define ap (make-audio-player audio-player-state audio-player-eof
|
||||
; #:remote-host "hans@mahler.thuis.local"
|
||||
; #:replace-base-paths '(("\\\\panderleou\\music" . "/muziek"))))
|
||||
(define (check-player)
|
||||
;(displayln "check-player called")
|
||||
(when (eq? player #f)
|
||||
(set! player
|
||||
(if (eq? player-kind 'local)
|
||||
(make-audio-player audio-state-cb on-eof-stream-cb)
|
||||
(make-audio-player audio-state-cb on-eof-stream-cb
|
||||
#:remote-host player-host
|
||||
#:replace-base-paths player-basepaths)))
|
||||
(audio-ao-buf-ms! player 500)
|
||||
(audio-buf-seconds! player buffer-min-seconds buffer-max-seconds)
|
||||
))
|
||||
|
||||
(define/public (change-player kind #:host [host #f] #:basepaths [basepaths #f])
|
||||
(let ((op player))
|
||||
(unless (eq? player #f)
|
||||
(set! player #f)
|
||||
(audio-quit! op)
|
||||
;(displayln "Player quit")
|
||||
)
|
||||
;(displayln "HE!")
|
||||
(set! player-kind kind)
|
||||
(set! player-host host)
|
||||
(set! player-basepaths basepaths)
|
||||
;(displayln (format "kind: ~a, host: ~a, bp: ~a, player: ~a" player-kind player-host player-basepaths player))
|
||||
))
|
||||
|
||||
(define/public (get-volume)
|
||||
(check-player)
|
||||
(* 100.0
|
||||
(sqrt
|
||||
(/ (min 100.0
|
||||
(max 0.0
|
||||
(audio-volume player)))
|
||||
100.0))))
|
||||
|
||||
(define/public (set-volume! percentage)
|
||||
(check-player)
|
||||
(let ((value
|
||||
(/ (min 100.0
|
||||
(max 0.0 percentage))
|
||||
100.0)))
|
||||
(audio-volume! player
|
||||
(* 100.0
|
||||
value
|
||||
value))))
|
||||
|
||||
(define/public (set-list! playlist*)
|
||||
;; if the player exists and is playing, stop it.
|
||||
(unless (eq? player #f)
|
||||
(audio-stop! player))
|
||||
;; Set the playlist to the new one.
|
||||
(set! playlist playlist*)
|
||||
;; reset music-id to -1, because the playlist has been reset.
|
||||
(set! music-id -1)
|
||||
;; clear lru cache, because the playlist has been reset.
|
||||
(clear-music-ids!)
|
||||
)
|
||||
|
||||
(define/public (playlist! playlist*)
|
||||
(check-player)
|
||||
(set-list! playlist*))
|
||||
|
||||
(define/public (play playlist*)
|
||||
(send this playlist! playlist*)
|
||||
(let ((track-nr
|
||||
(send playlist
|
||||
first-available-track-index)))
|
||||
(when track-nr
|
||||
(send this play-track track-nr))))
|
||||
|
||||
(define/public (play-track nr)
|
||||
(check-player)
|
||||
(when (and (>= nr 0) (< nr (send playlist length)))
|
||||
(let ((track (send playlist track nr)))
|
||||
(when track
|
||||
(let ((file
|
||||
(send playlist track-file nr)))
|
||||
(if file
|
||||
(let ((id (audio-play! player file)))
|
||||
(register-music-id&track-nr id nr))
|
||||
(warn-rktplayer
|
||||
"Track is not locally available: ~a"
|
||||
(send track get-title))))))))
|
||||
|
||||
(define/public (next)
|
||||
(check-player)
|
||||
(if (= music-id -1)
|
||||
(warn-rktplayer "No music-id set (yet), so can't play anything next")
|
||||
(let ((track-nr (music-id->track-nr music-id)))
|
||||
(if (eq? track-nr #f)
|
||||
(error "Unexpected: no track-nr for given music-id")
|
||||
(if (eq? repeat 'repeat-one)
|
||||
(send this play-track track-nr)
|
||||
(let ((next-track-nr
|
||||
(send playlist
|
||||
next-available-track-index
|
||||
track-nr
|
||||
(eq? repeat 'repeat-all))))
|
||||
(if next-track-nr
|
||||
(send this
|
||||
play-track
|
||||
next-track-nr)
|
||||
(send this stop))))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (previous)
|
||||
(check-player)
|
||||
(if (= music-id -1)
|
||||
(warn-rktplayer "No music-id set (yet), so can't play anything previous")
|
||||
(let ((track-nr (music-id->track-nr music-id)))
|
||||
(if (eq? track-nr #f)
|
||||
(error "Unexpected: no track-nr for given music-id")
|
||||
(if (eq? repeat 'repeat-one)
|
||||
(send this play-track track-nr)
|
||||
(let ((previous-track-nr
|
||||
(send playlist
|
||||
previous-available-track-index
|
||||
track-nr
|
||||
(eq? repeat 'repeat-all))))
|
||||
(send this
|
||||
play-track
|
||||
(or previous-track-nr
|
||||
track-nr))))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (pause!)
|
||||
(check-player)
|
||||
(audio-pause! player #t))
|
||||
|
||||
(define/public (play!)
|
||||
(check-player)
|
||||
(audio-pause! player #f))
|
||||
|
||||
(define/public (pause-unpause)
|
||||
(check-player)
|
||||
(if (audio-paused? player)
|
||||
(send this pause!)
|
||||
(send this play!)))
|
||||
|
||||
(define/public (stop)
|
||||
(unless (eq? player #f)
|
||||
(audio-stop! player)))
|
||||
|
||||
(define/public (seek percentage)
|
||||
(check-player)
|
||||
(audio-seek! player percentage))
|
||||
|
||||
(define/public (get-repeat)
|
||||
(check-player)
|
||||
repeat)
|
||||
|
||||
(define/public (repeat! r)
|
||||
(check-player)
|
||||
(set! repeat r))
|
||||
|
||||
(define/public (quit)
|
||||
(unless (eq? player #f)
|
||||
(audio-quit! player)))
|
||||
|
||||
(super-new)
|
||||
|
||||
(begin
|
||||
(dbg-rktplayer "player% initialized")
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -0,0 +1,163 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket/list
|
||||
"../../misc/utils.rkt")
|
||||
|
||||
(provide renderer%
|
||||
renderer-preferences%)
|
||||
|
||||
(define renderer-preferences%
|
||||
(class object%
|
||||
(init-field settings)
|
||||
|
||||
(define cfg
|
||||
(send settings clone 'renderers))
|
||||
|
||||
(define/private (stored)
|
||||
(send cfg get
|
||||
'volume-curves
|
||||
'()))
|
||||
|
||||
(define/public (get-volume-curve id)
|
||||
(let ((entry
|
||||
(assoc id
|
||||
(stored)
|
||||
equal?)))
|
||||
(if entry
|
||||
(cadr entry)
|
||||
'linear)))
|
||||
|
||||
(define/public (set-volume-curve! id curve)
|
||||
(check/c renderer-preferences%
|
||||
set-volume-curve!
|
||||
curve
|
||||
(or/c 'linear
|
||||
'logarithmic))
|
||||
(let ((without-id
|
||||
(filter
|
||||
(lambda (entry)
|
||||
(not
|
||||
(equal? (car entry)
|
||||
id)))
|
||||
(stored))))
|
||||
(send cfg
|
||||
set!
|
||||
'volume-curves
|
||||
(cons (list id curve)
|
||||
without-id))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define values (make-hash))
|
||||
(define test-settings%
|
||||
(class object%
|
||||
(define/public (clone name)
|
||||
(void name)
|
||||
this)
|
||||
(define/public (get name default)
|
||||
(hash-ref values name default))
|
||||
(define/public (set! name value)
|
||||
(hash-set! values name value))
|
||||
(super-new)))
|
||||
|
||||
(define preferences
|
||||
(new renderer-preferences%
|
||||
[settings (new test-settings%)]))
|
||||
(define renderer
|
||||
(new renderer%
|
||||
[id "renderer-id"]
|
||||
[name "Renderer"]
|
||||
[kind 'test]
|
||||
[device 'device]
|
||||
[preferences preferences]))
|
||||
|
||||
(check-= (send renderer
|
||||
logical-volume->device
|
||||
25)
|
||||
25
|
||||
0.001)
|
||||
(send renderer
|
||||
set-volume-curve!
|
||||
'logarithmic)
|
||||
(check-eq? (send renderer get-volume-curve)
|
||||
'logarithmic)
|
||||
(check-= (send renderer
|
||||
logical-volume->device
|
||||
50)
|
||||
25
|
||||
0.001)
|
||||
(check-= (send renderer
|
||||
device-volume->logical
|
||||
25)
|
||||
50
|
||||
0.001))
|
||||
|
||||
(define renderer%
|
||||
(class object%
|
||||
(init-field
|
||||
id
|
||||
name
|
||||
kind
|
||||
device
|
||||
preferences)
|
||||
|
||||
(check/c* renderer%
|
||||
(id string?)
|
||||
(name string?)
|
||||
(kind symbol?)
|
||||
(preferences
|
||||
(is-a?/c renderer-preferences%)))
|
||||
|
||||
(define/public (get-id)
|
||||
id)
|
||||
|
||||
(define/public (get-name)
|
||||
name)
|
||||
|
||||
(define/public (get-kind)
|
||||
kind)
|
||||
|
||||
(define/public (get-device)
|
||||
device)
|
||||
|
||||
(define/public (get-volume-curve)
|
||||
(send preferences
|
||||
get-volume-curve
|
||||
id))
|
||||
|
||||
(define/public (set-volume-curve! curve)
|
||||
(send preferences
|
||||
set-volume-curve!
|
||||
id
|
||||
curve))
|
||||
|
||||
(define/private (clamp percentage)
|
||||
(min 100.0
|
||||
(max 0.0
|
||||
percentage)))
|
||||
|
||||
(define/public (logical-volume->device percentage)
|
||||
(let ((value
|
||||
(/ (clamp percentage)
|
||||
100.0)))
|
||||
(* 100.0
|
||||
(case (send this get-volume-curve)
|
||||
((logarithmic)
|
||||
(* value value))
|
||||
(else value)))))
|
||||
|
||||
(define/public (device-volume->logical percentage)
|
||||
(let ((value
|
||||
(/ (clamp percentage)
|
||||
100.0)))
|
||||
(* 100.0
|
||||
(case (send this get-volume-curve)
|
||||
((logarithmic)
|
||||
(sqrt value))
|
||||
(else value)))))
|
||||
|
||||
(super-new)))
|
||||
@@ -0,0 +1,588 @@
|
||||
#lang racket
|
||||
|
||||
(require racket/class
|
||||
racket/path
|
||||
(prefix-in rad: racket-audio-dlna)
|
||||
"../library/base/media-resource.rkt"
|
||||
"base/renderer.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide dlna-player%)
|
||||
|
||||
(define dlna-player%
|
||||
(class object%
|
||||
(init-field [renderer #f]
|
||||
[settings #f]
|
||||
[time-updater (lambda (time-s length-s) #t)]
|
||||
[track-nr-updater (lambda (nr) #t)]
|
||||
[state-updater (lambda (state) #t)]
|
||||
[error-updater
|
||||
(lambda (kind detail) #t)]
|
||||
[repeat-updater (lambda (state) #t)]
|
||||
[audio-info-cb (lambda (rate channels bits kind) #t)]
|
||||
[buffer-max-seconds 10]
|
||||
[buffer-min-seconds 4]
|
||||
[server-url #f]
|
||||
[server-port 8734] ;8080]
|
||||
[listen-ip #f]
|
||||
[poll-seconds 1.0]
|
||||
[volume-poll-seconds 5.0])
|
||||
|
||||
(define player #f)
|
||||
(define playlist #f)
|
||||
(define state 'stopped)
|
||||
(define repeat 'no-repeat)
|
||||
(define current-track-nr #f)
|
||||
(define current-uri #f)
|
||||
(define prepared-next-track-nr #f)
|
||||
(define playing-seen? #f)
|
||||
(define playback-progress-seen? #f)
|
||||
(define playback-failure-active? #f)
|
||||
(define play-request-ms #f)
|
||||
(define stop-requested? #f)
|
||||
(define stopped-polls 0)
|
||||
(define renderer-reachable? #t)
|
||||
(define playback-start-timeout-ms 8000)
|
||||
(define running #t)
|
||||
(define poll-thread #f)
|
||||
|
||||
(define (now-ms)
|
||||
(current-inexact-milliseconds))
|
||||
|
||||
(define (track-title nr)
|
||||
(let ((track
|
||||
(and playlist
|
||||
(exact-nonnegative-integer? nr)
|
||||
(send playlist track nr))))
|
||||
(if track
|
||||
(send track get-title)
|
||||
"")))
|
||||
|
||||
(define (report-playback-failure! detail)
|
||||
(set! playing-seen? #f)
|
||||
(set! playback-progress-seen? #f)
|
||||
(set! playback-failure-active? #t)
|
||||
(set! play-request-ms #f)
|
||||
(set! stopped-polls 0)
|
||||
(error-updater 'playback-failed detail))
|
||||
|
||||
(define (renderer-command! name command)
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (e)
|
||||
(warn-rktplayer
|
||||
"Could not execute DLNA command ~a: ~a"
|
||||
name
|
||||
(exn-message e))
|
||||
(error-updater
|
||||
'renderer-command-failed
|
||||
(send renderer get-name))
|
||||
#f)))
|
||||
(command)
|
||||
#t))
|
||||
|
||||
(define (check-player)
|
||||
(unless (is-a? renderer renderer%)
|
||||
(raise-arguments-error
|
||||
'dlna-player%
|
||||
"no media renderer has been configured"
|
||||
"renderer" renderer))
|
||||
(when (eq? player #f)
|
||||
(unless (eq? server-url #f)
|
||||
(warn-rktplayer
|
||||
"server-url is ignored; racket-audio-dlna determines the server URL"))
|
||||
(set! player
|
||||
(rad:make-dlna-player
|
||||
(send renderer get-device)
|
||||
#:listen-ip listen-ip
|
||||
#:port server-port
|
||||
#:path "/rktplayer/"
|
||||
#:poll-seconds poll-seconds
|
||||
#:volume-poll-seconds volume-poll-seconds))))
|
||||
|
||||
(define (normalize-state st)
|
||||
(cond
|
||||
[(eq? st 'playing) 'playing]
|
||||
[(eq? st 'transitioning) 'starting]
|
||||
[(eq? st 'paused) 'paused]
|
||||
[(or (eq? st 'stopped)
|
||||
(eq? st 'no-media))
|
||||
'stopped]
|
||||
[else st]))
|
||||
|
||||
(define (set-state! st)
|
||||
(unless (eq? state st)
|
||||
(set! state st)
|
||||
(state-updater state))
|
||||
(repeat-updater repeat)
|
||||
(when (or (eq? state 'stopped)
|
||||
(eq? state 'quit))
|
||||
(audio-info-cb 0 0 0 'none)))
|
||||
|
||||
(define (file-format file)
|
||||
(let* ((value
|
||||
(cond
|
||||
((path? file) (path->string file))
|
||||
((string? file) file)
|
||||
(else #f)))
|
||||
(match
|
||||
(and value
|
||||
(regexp-match
|
||||
#px"(?i:[.]([a-z0-9]+)(?:[?#].*)?$)"
|
||||
value))))
|
||||
(if match
|
||||
(string->symbol (string-downcase (cadr match)))
|
||||
'none)))
|
||||
|
||||
(define (track-audio-info! track)
|
||||
(if track
|
||||
(audio-info-cb
|
||||
(or (rad:dlna-track-info-sample-rate track) 0)
|
||||
(or (rad:dlna-track-info-channels track) 0)
|
||||
0
|
||||
(file-format (rad:dlna-track-info-file track)))
|
||||
(audio-info-cb 0 0 0 'none)))
|
||||
|
||||
(define (normalized-file file)
|
||||
(with-handlers ([exn:fail? (lambda (_) (format "~a" file))])
|
||||
(path->string (path->complete-path file))))
|
||||
|
||||
(define (same-file? file1 file2)
|
||||
(and file1
|
||||
file2
|
||||
((if (eq? (system-type 'os) 'windows)
|
||||
string-ci=?
|
||||
string=?)
|
||||
(normalized-file file1)
|
||||
(normalized-file file2))))
|
||||
|
||||
(define (playlist-track-file nr)
|
||||
(let* ((track (send playlist track nr))
|
||||
(resource
|
||||
(and track
|
||||
(send track get-resource))))
|
||||
(and resource
|
||||
(is-a? resource media-resource%)
|
||||
(send resource get-file))))
|
||||
|
||||
(define (playlist-track-uri nr)
|
||||
(let ((track (send playlist track nr)))
|
||||
(and track
|
||||
(send (send track get-resource)
|
||||
get-uri))))
|
||||
|
||||
(define (playlist-track-info nr)
|
||||
(let* ((track (send playlist track nr))
|
||||
(resource (send track get-resource)))
|
||||
(rad:dlna-track-info
|
||||
(or (send resource get-file)
|
||||
(send resource get-uri))
|
||||
(send track get-title)
|
||||
(send track get-artist)
|
||||
(send track get-album)
|
||||
#f
|
||||
#f
|
||||
(send track get-number)
|
||||
(send track get-length)
|
||||
#f
|
||||
#f
|
||||
#f)))
|
||||
|
||||
(define (playlist-track-mime-type nr)
|
||||
(send (send (send playlist track nr)
|
||||
get-resource)
|
||||
get-mime-type))
|
||||
|
||||
(define (playlist-track-protocol-info nr)
|
||||
(send (send (send playlist track nr)
|
||||
get-resource)
|
||||
get-protocol-info))
|
||||
|
||||
(define (playlist-track-nr file uri)
|
||||
(and playlist
|
||||
(for/first ([nr (in-range (send playlist length))]
|
||||
#:when
|
||||
(or (same-file?
|
||||
file
|
||||
(playlist-track-file nr))
|
||||
(and (string? uri)
|
||||
(equal?
|
||||
uri
|
||||
(playlist-track-uri nr)))))
|
||||
nr)))
|
||||
|
||||
(define (next-track-nr nr)
|
||||
(if (eq? repeat 'repeat-one)
|
||||
nr
|
||||
(send playlist
|
||||
next-valid-track-index
|
||||
nr
|
||||
(eq? repeat 'repeat-all))))
|
||||
|
||||
(define (prepare-next-track!)
|
||||
(when (and player
|
||||
playlist
|
||||
(exact-nonnegative-integer? current-track-nr))
|
||||
(let ((nr (next-track-nr current-track-nr)))
|
||||
(cond
|
||||
[(eq? nr #f)
|
||||
(set! prepared-next-track-nr #f)]
|
||||
[(not (equal? nr prepared-next-track-nr))
|
||||
(let ((file (playlist-track-file nr)))
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (e)
|
||||
(set! prepared-next-track-nr #f)
|
||||
(warn-rktplayer
|
||||
"Could not prepare next DLNA track: ~a"
|
||||
(exn-message e)))])
|
||||
(if file
|
||||
(rad:dlna-player-set-next-file!
|
||||
player
|
||||
file)
|
||||
(rad:dlna-player-set-next-uri!
|
||||
player
|
||||
(playlist-track-uri nr)
|
||||
#:mime-type
|
||||
(playlist-track-mime-type nr)
|
||||
#:protocol-info
|
||||
(playlist-track-protocol-info nr)
|
||||
#:track
|
||||
(playlist-track-info nr)))
|
||||
(set! prepared-next-track-nr nr)))]))))
|
||||
|
||||
(define (update-current-track! info)
|
||||
(let* ((track (rad:dlna-info-track info))
|
||||
(file (and track (rad:dlna-track-info-file track)))
|
||||
(uri (rad:dlna-info-uri info))
|
||||
(nr (cond
|
||||
[(and (exact-nonnegative-integer?
|
||||
prepared-next-track-nr)
|
||||
(or
|
||||
(same-file?
|
||||
file
|
||||
(playlist-track-file
|
||||
prepared-next-track-nr))
|
||||
(and (string? uri)
|
||||
(equal?
|
||||
uri
|
||||
(playlist-track-uri
|
||||
prepared-next-track-nr)))))
|
||||
prepared-next-track-nr]
|
||||
[else
|
||||
(playlist-track-nr file uri)])))
|
||||
(when (exact-nonnegative-integer? nr)
|
||||
(unless (equal? nr current-track-nr)
|
||||
(set! playback-progress-seen? #f)
|
||||
(set! play-request-ms (now-ms)))
|
||||
(set! current-track-nr nr)
|
||||
(set! prepared-next-track-nr #f)
|
||||
(track-nr-updater nr)
|
||||
(track-audio-info! track)
|
||||
(prepare-next-track!))))
|
||||
|
||||
(define (poll-renderer)
|
||||
(when player
|
||||
(let ((info (rad:dlna-player-info player)))
|
||||
(if (not (rad:dlna-info-reachable? info))
|
||||
(when renderer-reachable?
|
||||
(set! renderer-reachable? #f)
|
||||
(warn-rktplayer "DLNA renderer is not reachable")
|
||||
(error-updater
|
||||
'renderer-unreachable
|
||||
(send renderer get-name)))
|
||||
(let* ((new-state
|
||||
(normalize-state (rad:dlna-info-state info)))
|
||||
(uri (rad:dlna-info-uri info))
|
||||
(position (rad:dlna-info-position info))
|
||||
(duration (rad:dlna-info-duration info))
|
||||
(playback-failed? #f))
|
||||
(unless renderer-reachable?
|
||||
(dbg-rktplayer "DLNA renderer is reachable again"))
|
||||
(set! renderer-reachable? #t)
|
||||
|
||||
(when (and (string? uri)
|
||||
(not (string=? uri ""))
|
||||
(not (equal? uri current-uri)))
|
||||
(set! current-uri uri)
|
||||
(set! stopped-polls 0)
|
||||
(update-current-track! info))
|
||||
|
||||
(when (or (eq? new-state 'playing)
|
||||
(eq? new-state 'starting)
|
||||
(eq? new-state 'paused))
|
||||
(when (and (number? position)
|
||||
(> position 0))
|
||||
(set! playback-progress-seen? #t))
|
||||
(when (and (number? position)
|
||||
(number? duration))
|
||||
(time-updater position duration))
|
||||
(track-audio-info! (rad:dlna-info-track info)))
|
||||
|
||||
(when (and playing-seen?
|
||||
(not playback-progress-seen?)
|
||||
play-request-ms
|
||||
(>= (- (now-ms)
|
||||
play-request-ms)
|
||||
playback-start-timeout-ms))
|
||||
(set! playback-failed? #t)
|
||||
(report-playback-failure!
|
||||
(track-title current-track-nr)))
|
||||
|
||||
(unless (or playback-failed?
|
||||
playback-failure-active?)
|
||||
(cond
|
||||
[(eq? new-state 'playing)
|
||||
(set! playing-seen? #t)
|
||||
(set! stopped-polls 0)]
|
||||
[(and (eq? new-state 'stopped)
|
||||
stop-requested?)
|
||||
(set! stop-requested? #f)
|
||||
(set! stopped-polls 0)]
|
||||
[(and (eq? new-state 'stopped)
|
||||
playing-seen?)
|
||||
(cond
|
||||
((and
|
||||
(not playback-progress-seen?)
|
||||
play-request-ms
|
||||
(< (- (now-ms)
|
||||
play-request-ms)
|
||||
5000))
|
||||
(void))
|
||||
((not playback-progress-seen?)
|
||||
(report-playback-failure!
|
||||
(track-title current-track-nr)))
|
||||
(else
|
||||
(set! stopped-polls
|
||||
(+ stopped-polls 1))
|
||||
;; Give SetNextAVTransportURI one poll to take over.
|
||||
(when (or
|
||||
(eq? prepared-next-track-nr #f)
|
||||
(> stopped-polls 1))
|
||||
(set! playing-seen? #f)
|
||||
(set! stopped-polls 0)
|
||||
(send this next))))]))
|
||||
|
||||
(set-state!
|
||||
(cond
|
||||
((or playback-failed?
|
||||
playback-failure-active?)
|
||||
'stopped)
|
||||
((and playing-seen?
|
||||
(not playback-progress-seen?))
|
||||
'starting)
|
||||
(else new-state))))))))
|
||||
|
||||
(define (poll)
|
||||
(let loop ()
|
||||
(when running
|
||||
(sleep poll-seconds)
|
||||
(when running
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (e)
|
||||
(warn-rktplayer
|
||||
"Could not update DLNA player state: ~a"
|
||||
(exn-message e)))])
|
||||
(poll-renderer))
|
||||
(loop)))))
|
||||
|
||||
(define/public (change-player kind
|
||||
#:host [host #f]
|
||||
#:basepaths [basepaths #f])
|
||||
(void kind host basepaths)
|
||||
(warn-rktplayer
|
||||
"change-player is not supported by dlna-player%"))
|
||||
|
||||
(define/public (get-volume)
|
||||
(check-player)
|
||||
(send renderer
|
||||
device-volume->logical
|
||||
(or (rad:dlna-info-volume
|
||||
(rad:dlna-player-info player))
|
||||
0)))
|
||||
|
||||
(define/public (set-volume! percentage)
|
||||
(check-player)
|
||||
(renderer-command!
|
||||
'volume
|
||||
(lambda ()
|
||||
(rad:dlna-player-volume!
|
||||
player
|
||||
(send renderer
|
||||
logical-volume->device
|
||||
percentage)))))
|
||||
|
||||
(define/public (set-list! playlist*)
|
||||
(when player
|
||||
(with-handlers ([exn:fail? (lambda (_) (void))])
|
||||
(rad:dlna-player-stop! player)))
|
||||
(set! playlist playlist*)
|
||||
(set! current-track-nr #f)
|
||||
(set! current-uri #f)
|
||||
(set! prepared-next-track-nr #f)
|
||||
(set! playing-seen? #f)
|
||||
(set! playback-progress-seen? #f)
|
||||
(set! playback-failure-active? #f)
|
||||
(set! play-request-ms #f)
|
||||
(set! stop-requested? #f)
|
||||
(set! stopped-polls 0)
|
||||
(set-state! 'stopped))
|
||||
|
||||
(define/public (playlist! playlist*)
|
||||
(check-player)
|
||||
(set-list! playlist*))
|
||||
|
||||
(define/public (play playlist*)
|
||||
(send this playlist! playlist*)
|
||||
(let ((track-nr
|
||||
(send playlist
|
||||
first-valid-track-index)))
|
||||
(when track-nr
|
||||
(send this play-track track-nr))))
|
||||
|
||||
(define/public (play-track nr)
|
||||
(check-player)
|
||||
(when (and playlist
|
||||
(>= nr 0)
|
||||
(< nr (send playlist length)))
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (e)
|
||||
(warn-rktplayer
|
||||
"Could not play DLNA track: ~a"
|
||||
(exn-message e))
|
||||
(report-playback-failure!
|
||||
(track-title nr))
|
||||
(set-state! 'stopped))))
|
||||
(let ((file (playlist-track-file nr)))
|
||||
(if file
|
||||
(rad:dlna-player-play! player file)
|
||||
(rad:dlna-player-play-uri!
|
||||
player
|
||||
(playlist-track-uri nr)
|
||||
#:mime-type
|
||||
(playlist-track-mime-type nr)
|
||||
#:protocol-info
|
||||
(playlist-track-protocol-info nr)
|
||||
#:track
|
||||
(playlist-track-info nr)))
|
||||
(when (or file
|
||||
(playlist-track-uri nr))
|
||||
(let ((info (rad:dlna-player-info player)))
|
||||
(set! current-track-nr nr)
|
||||
(set! current-uri (rad:dlna-info-uri info))
|
||||
(set! prepared-next-track-nr #f)
|
||||
(set! playing-seen? #t)
|
||||
(set! playback-progress-seen? #f)
|
||||
(set! playback-failure-active? #f)
|
||||
(set! play-request-ms (now-ms))
|
||||
(set! stop-requested? #f)
|
||||
(set! stopped-polls 0)
|
||||
(track-nr-updater nr)
|
||||
(track-audio-info! (rad:dlna-info-track info))
|
||||
(set-state! 'starting)
|
||||
(prepare-next-track!)))))))
|
||||
|
||||
(define/public (next)
|
||||
(check-player)
|
||||
(if (eq? current-track-nr #f)
|
||||
(warn-rktplayer
|
||||
"No track-nr set (yet), so can't play anything next")
|
||||
(let ((nr (next-track-nr current-track-nr)))
|
||||
(if (eq? nr #f)
|
||||
(send this stop)
|
||||
(send this play-track nr)))))
|
||||
|
||||
(define/public (previous)
|
||||
(check-player)
|
||||
(if (eq? current-track-nr #f)
|
||||
(warn-rktplayer
|
||||
"No track-nr set (yet), so can't play anything previous")
|
||||
(let ((nr current-track-nr))
|
||||
(if (eq? repeat 'repeat-one)
|
||||
(send this play-track nr)
|
||||
(let ((previous-track-nr
|
||||
(send playlist
|
||||
previous-valid-track-index
|
||||
nr
|
||||
(eq? repeat 'repeat-all))))
|
||||
(send this
|
||||
play-track
|
||||
(or previous-track-nr
|
||||
nr)))))))
|
||||
|
||||
(define/public (pause!)
|
||||
(check-player)
|
||||
(when (renderer-command!
|
||||
'pause
|
||||
(lambda ()
|
||||
(rad:dlna-player-pause! player)))
|
||||
(set-state! 'paused)))
|
||||
|
||||
(define/public (play!)
|
||||
(check-player)
|
||||
(when (renderer-command!
|
||||
'play
|
||||
(lambda ()
|
||||
(rad:dlna-player-resume! player)))
|
||||
(set-state! 'playing)))
|
||||
|
||||
(define/public (pause-unpause)
|
||||
(check-player)
|
||||
(if (eq? state 'paused)
|
||||
(send this play!)
|
||||
(send this pause!)))
|
||||
|
||||
(define/public (stop)
|
||||
(set! stop-requested? #t)
|
||||
(set! playing-seen? #f)
|
||||
(set! playback-progress-seen? #f)
|
||||
(set! playback-failure-active? #f)
|
||||
(set! play-request-ms #f)
|
||||
(set! stopped-polls 0)
|
||||
(unless (eq? player #f)
|
||||
(renderer-command!
|
||||
'stop
|
||||
(lambda ()
|
||||
(rad:dlna-player-stop! player))))
|
||||
(set-state! 'stopped))
|
||||
|
||||
(define/public (seek percentage)
|
||||
(check-player)
|
||||
(renderer-command!
|
||||
'seek
|
||||
(lambda ()
|
||||
(rad:dlna-player-seek-percentage!
|
||||
player
|
||||
percentage))))
|
||||
|
||||
(define/public (get-repeat)
|
||||
(check-player)
|
||||
repeat)
|
||||
|
||||
(define/public (repeat! r)
|
||||
(check-player)
|
||||
(set! repeat r)
|
||||
(repeat-updater repeat)
|
||||
(prepare-next-track!))
|
||||
|
||||
(define/public (quit)
|
||||
(when running
|
||||
(set! running #f)
|
||||
(unless (eq? poll-thread #f)
|
||||
(kill-thread poll-thread)
|
||||
(set! poll-thread #f))
|
||||
(unless (eq? player #f)
|
||||
(rad:dlna-player-close! player)
|
||||
(set! player #f))
|
||||
(set-state! 'quit)))
|
||||
|
||||
(super-new)
|
||||
|
||||
(begin
|
||||
(void settings
|
||||
buffer-max-seconds
|
||||
buffer-min-seconds)
|
||||
(set! poll-thread (thread poll))
|
||||
(dbg-rktplayer "dlna-player% initialized"))))
|
||||
+113
@@ -0,0 +1,113 @@
|
||||
#lang racket
|
||||
|
||||
(require racket/class
|
||||
racket/list
|
||||
racket-sonos
|
||||
racket-upnp
|
||||
"renderer-sonos.rkt"
|
||||
"renderer-upnp.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide check-dlna-players)
|
||||
|
||||
(define running-sem (make-semaphore 1))
|
||||
(define running #f)
|
||||
|
||||
(define (normalized-device-id device)
|
||||
(let ((id (upnp-device-udn device)))
|
||||
(and id
|
||||
(let ((match
|
||||
(regexp-match
|
||||
#px"(?i:RINCON_[0-9A-F]+)"
|
||||
id)))
|
||||
(if match
|
||||
(string-upcase
|
||||
(car match))
|
||||
(regexp-replace
|
||||
#px"(?i:^uuid:)"
|
||||
id
|
||||
""))))))
|
||||
|
||||
(define (represented-by-sonos-group? device member-ids)
|
||||
(let ((id (normalized-device-id device)))
|
||||
(and id
|
||||
(ormap
|
||||
(lambda (member-id)
|
||||
(string-ci=? id member-id))
|
||||
member-ids))))
|
||||
|
||||
(define (make-generic-renderers devices preferences
|
||||
#:excluded-ids [excluded-ids '()])
|
||||
(for/list ((device
|
||||
(in-list
|
||||
(filter media-renderer? devices)))
|
||||
#:unless
|
||||
(represented-by-sonos-group?
|
||||
device
|
||||
excluded-ids))
|
||||
(new renderer-upnp%
|
||||
[upnp-device device]
|
||||
[name
|
||||
(if (sonos-device? device)
|
||||
(sonos-device-name device)
|
||||
#f)]
|
||||
[preferences preferences])))
|
||||
|
||||
(define (discover-renderers preferences)
|
||||
(let* ((devices (query-upnp-devices 'all))
|
||||
(groups
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (e)
|
||||
(warn-rktplayer
|
||||
"Could not read Sonos topology; using generic UPnP renderers: ~a"
|
||||
(exn-message e))
|
||||
'())))
|
||||
(sonos-groups devices)))
|
||||
(renderers
|
||||
(if (null? groups)
|
||||
(make-generic-renderers
|
||||
devices
|
||||
preferences)
|
||||
(append
|
||||
(make-generic-renderers
|
||||
devices
|
||||
preferences
|
||||
#:excluded-ids
|
||||
(append-map
|
||||
sonos-group-member-ids
|
||||
groups))
|
||||
(for/list ((group (in-list groups)))
|
||||
(new renderer-sonos%
|
||||
[sonos-group group]
|
||||
[preferences preferences]))))))
|
||||
(sort renderers
|
||||
string-ci<?
|
||||
#:key
|
||||
(lambda (renderer)
|
||||
(send renderer get-name)))))
|
||||
|
||||
(define (check-dlna-players gui preferences)
|
||||
(let ((can-check
|
||||
(begin
|
||||
(semaphore-wait running-sem)
|
||||
(let ((was-running running))
|
||||
(unless was-running
|
||||
(set! running #t))
|
||||
(semaphore-post running-sem)
|
||||
(not was-running)))))
|
||||
(if can-check
|
||||
(void
|
||||
(thread
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(send gui
|
||||
set-dlna-renderers!
|
||||
(discover-renderers preferences)))
|
||||
(lambda ()
|
||||
(semaphore-wait running-sem)
|
||||
(set! running #f)
|
||||
(semaphore-post running-sem))))))
|
||||
(send gui dlna-query-busy))))
|
||||
@@ -0,0 +1,280 @@
|
||||
#lang racket/base
|
||||
|
||||
(require net/url
|
||||
racket/async-channel
|
||||
racket/class
|
||||
racket/file
|
||||
racket/path
|
||||
racket/string
|
||||
"../library/base/media-resource.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide playlist-cache%
|
||||
playlist-cache-root
|
||||
clear-playlist-cache!)
|
||||
|
||||
(define (playlist-cache-root)
|
||||
(build-path (find-system-path 'cache-dir)
|
||||
"rktplayer"))
|
||||
|
||||
(define (safe-name value)
|
||||
(regexp-replace* #px"[<>:\"/\\\\|?*]"
|
||||
(format "~a" value)
|
||||
"_"))
|
||||
|
||||
(define (resource-extension resource)
|
||||
(let* ((uri (send resource get-uri))
|
||||
(without-query
|
||||
(regexp-replace #px"[?#].*$" uri ""))
|
||||
(uri-extension
|
||||
(regexp-match #px"(?i:[.]([a-z0-9]{1,8})$)"
|
||||
without-query))
|
||||
(mime-type (send resource get-mime-type)))
|
||||
(cond
|
||||
(uri-extension
|
||||
(string-append "."
|
||||
(string-downcase
|
||||
(cadr uri-extension))))
|
||||
((member mime-type
|
||||
'("audio/flac"
|
||||
"audio/x-flac"
|
||||
"application/flac")) ".flac")
|
||||
((or (equal? mime-type "audio/mpeg")
|
||||
(equal? mime-type "audio/mp3")) ".mp3")
|
||||
((or (equal? mime-type "audio/opus")
|
||||
(equal? mime-type "audio/ogg")) ".opus")
|
||||
((member mime-type
|
||||
'("audio/wav"
|
||||
"audio/wave"
|
||||
"audio/x-wav")) ".wav")
|
||||
((member mime-type
|
||||
'("audio/mp4"
|
||||
"audio/x-m4a")) ".m4a")
|
||||
((equal? mime-type "audio/aac") ".aac")
|
||||
((equal? mime-type "audio/x-ms-wma") ".wma")
|
||||
(else ".audio"))))
|
||||
|
||||
(define (content-length headers)
|
||||
(for/or ((header (in-list headers)))
|
||||
(let ((matched
|
||||
(regexp-match
|
||||
#px#"(?i:^content-length:[ \t]*([0-9]+)[ \t]*$)"
|
||||
header)))
|
||||
(and matched
|
||||
(string->number
|
||||
(bytes->string/utf-8
|
||||
(cadr matched)))))))
|
||||
|
||||
(define (successful-status? status)
|
||||
(regexp-match? #px#"^HTTP/[0-9.]+ 2[0-9][0-9]" status))
|
||||
|
||||
(define (clear-playlist-cache! [playlist-id #f])
|
||||
(let ((target
|
||||
(if playlist-id
|
||||
(build-path (playlist-cache-root)
|
||||
(safe-name playlist-id))
|
||||
(playlist-cache-root))))
|
||||
(when (directory-exists? target)
|
||||
(with-handlers ([exn:fail? (lambda (e) (void))])
|
||||
(delete-directory/files target)))))
|
||||
|
||||
(define playlist-cache%
|
||||
(class object%
|
||||
(init-field
|
||||
playlist-id
|
||||
[updated (lambda (entry downloaded total) (void))])
|
||||
|
||||
(define directory
|
||||
(build-path (playlist-cache-root)
|
||||
(safe-name playlist-id)))
|
||||
|
||||
(define queue
|
||||
(make-async-channel))
|
||||
|
||||
(define generations
|
||||
(make-hash))
|
||||
|
||||
(define stopped?
|
||||
#f)
|
||||
|
||||
(define worker-custodian
|
||||
(make-custodian))
|
||||
|
||||
(define/private (entry-generation entry)
|
||||
(hash-ref generations
|
||||
(send entry get-id)
|
||||
0))
|
||||
|
||||
(define/private (next-generation! entry)
|
||||
(hash-update! generations
|
||||
(send entry get-id)
|
||||
add1
|
||||
0)
|
||||
(entry-generation entry))
|
||||
|
||||
(define/private (cache-file entry)
|
||||
(let ((resource
|
||||
(send (send entry get-track)
|
||||
get-resource)))
|
||||
(build-path directory
|
||||
(string-append
|
||||
(safe-name (send entry get-id))
|
||||
(resource-extension resource)))))
|
||||
|
||||
(define/private (notify! entry downloaded total)
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (exception)
|
||||
(warn-rktplayer
|
||||
"Cache status callback failed: ~a"
|
||||
(exn-message exception)))))
|
||||
(updated entry downloaded total)))
|
||||
|
||||
(define/private (copy-download!
|
||||
input temporary entry total)
|
||||
(let ((downloaded 0)
|
||||
(last-reported 0)
|
||||
(buffer (make-bytes 65536)))
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(call-with-output-file
|
||||
temporary
|
||||
(lambda (output)
|
||||
(let loop ()
|
||||
(let ((count
|
||||
(read-bytes-avail!* buffer input)))
|
||||
(unless (eof-object? count)
|
||||
(write-bytes buffer output 0 count)
|
||||
(set! downloaded (+ downloaded count))
|
||||
(when (>= (- downloaded last-reported)
|
||||
1048576)
|
||||
(set! last-reported downloaded)
|
||||
(notify! entry downloaded total))
|
||||
(loop)))))
|
||||
#:exists 'replace
|
||||
#:mode 'binary))
|
||||
(lambda ()
|
||||
(close-input-port input)))
|
||||
downloaded))
|
||||
|
||||
(define/private (finish-download!
|
||||
entry generation target temporary
|
||||
downloaded total)
|
||||
(if (and (not stopped?)
|
||||
(= generation
|
||||
(entry-generation entry)))
|
||||
(begin
|
||||
(when (file-exists? target)
|
||||
(delete-file target))
|
||||
(rename-file-or-directory temporary target)
|
||||
(send entry set-cache-file! target)
|
||||
(notify! entry downloaded total))
|
||||
(when (file-exists? temporary)
|
||||
(delete-file temporary))))
|
||||
|
||||
(define/private (download! entry generation)
|
||||
(let* ((resource
|
||||
(send (send entry get-track)
|
||||
get-resource))
|
||||
(uri (send resource get-uri))
|
||||
(target (cache-file entry))
|
||||
(temporary
|
||||
(string->path
|
||||
(string-append (path->string target)
|
||||
".part"))))
|
||||
(let ((finished? #f))
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(make-directory* directory)
|
||||
(let-values
|
||||
(((status headers input)
|
||||
(http-sendrecv/url
|
||||
(string->url uri)
|
||||
#:headers
|
||||
(list "Connection: close"))))
|
||||
(unless (successful-status? status)
|
||||
(close-input-port input)
|
||||
(error 'playlist-cache%
|
||||
"download failed for ~a: ~a"
|
||||
uri
|
||||
status))
|
||||
(let* ((total (content-length headers))
|
||||
(downloaded
|
||||
(copy-download!
|
||||
input temporary entry total)))
|
||||
(finish-download!
|
||||
entry generation target temporary
|
||||
downloaded total)
|
||||
(set! finished? #t))))
|
||||
(lambda ()
|
||||
(when (and (not finished?)
|
||||
(file-exists? temporary))
|
||||
(delete-file temporary)))))))
|
||||
|
||||
(define worker
|
||||
(parameterize
|
||||
((current-custodian worker-custodian))
|
||||
(thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ((request (async-channel-get queue)))
|
||||
(unless (eq? request 'stop)
|
||||
(let ((entry (car request))
|
||||
(generation (cadr request)))
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (exception)
|
||||
(when (= generation
|
||||
(entry-generation entry))
|
||||
(send entry
|
||||
set-cache-failed!
|
||||
(exn-message exception))
|
||||
(notify! entry 0 #f)))))
|
||||
(download! entry generation))
|
||||
(loop)))))))))
|
||||
|
||||
(define/public (ensure-entry! entry)
|
||||
(let ((track (send entry get-track)))
|
||||
(when track
|
||||
(let* ((resource (send track get-resource))
|
||||
(file (send resource get-file)))
|
||||
(cond
|
||||
(file
|
||||
(send entry set-cache-file! file))
|
||||
((regexp-match? #px"(?i:^https?://)"
|
||||
(send resource get-uri))
|
||||
(let ((target (cache-file entry)))
|
||||
(if (file-exists? target)
|
||||
(send entry set-cache-file! target)
|
||||
(let ((generation
|
||||
(next-generation! entry)))
|
||||
(send entry set-cache-downloading!)
|
||||
(notify! entry 0 #f)
|
||||
(async-channel-put
|
||||
queue
|
||||
(list entry generation)))))))))))
|
||||
|
||||
(define/public (drop-entry! entry)
|
||||
(next-generation! entry)
|
||||
(let ((file (send entry get-cache-file)))
|
||||
(when (and file
|
||||
(path? file)
|
||||
(file-exists? file)
|
||||
(equal? (simplify-path directory)
|
||||
(simplify-path
|
||||
(path-only file))))
|
||||
(delete-file file))))
|
||||
|
||||
(define/public (clear!)
|
||||
(when (directory-exists? directory)
|
||||
(delete-directory/files directory)))
|
||||
|
||||
(define/public (stop!)
|
||||
(unless stopped?
|
||||
(set! stopped? #t)
|
||||
(custodian-shutdown-all
|
||||
worker-custodian)))
|
||||
|
||||
(super-new)))
|
||||
@@ -0,0 +1,194 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"../library/library-factory.rkt"
|
||||
"../library/track-store.rkt"
|
||||
"../library/base/track.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide playlist-entry%
|
||||
track->playlist-entry
|
||||
store->playlist-entry)
|
||||
|
||||
(define playlist-entry%
|
||||
(class object%
|
||||
(init-field
|
||||
stored
|
||||
[track #f])
|
||||
|
||||
(check/c* playlist-entry%
|
||||
(stored track-store?)
|
||||
(track (or/c #f (is-a?/c track<%>))))
|
||||
|
||||
(define/public (is-valid?)
|
||||
(not (eq? track #f)))
|
||||
|
||||
(define/public (get-track)
|
||||
track)
|
||||
|
||||
(define cache-file
|
||||
(and track
|
||||
(send (send track get-resource)
|
||||
get-file)))
|
||||
|
||||
(define cache-status
|
||||
(if cache-file 'available 'unavailable))
|
||||
|
||||
(define cache-error
|
||||
#f)
|
||||
|
||||
(define/public (get-cache-file)
|
||||
(if (and cache-file
|
||||
(file-exists? cache-file))
|
||||
cache-file
|
||||
(begin
|
||||
(set! cache-file #f)
|
||||
(unless (eq? cache-status 'downloading)
|
||||
(set! cache-status 'unavailable))
|
||||
#f)))
|
||||
|
||||
(define/public (get-cache-status)
|
||||
cache-status)
|
||||
|
||||
(define/public (get-cache-error)
|
||||
cache-error)
|
||||
|
||||
(define/public (is-available?)
|
||||
(and (send this is-valid?)
|
||||
(eq? cache-status 'available)
|
||||
(send this get-cache-file)
|
||||
#t))
|
||||
|
||||
(define/public (set-cache-downloading!)
|
||||
(set! cache-file #f)
|
||||
(set! cache-status 'downloading)
|
||||
(set! cache-error #f))
|
||||
|
||||
(define/public (set-cache-file! file)
|
||||
(set! cache-file file)
|
||||
(set! cache-status 'available)
|
||||
(set! cache-error #f))
|
||||
|
||||
(define/public (set-cache-failed! message)
|
||||
(set! cache-file #f)
|
||||
(set! cache-status 'failed)
|
||||
(set! cache-error message))
|
||||
|
||||
(define/public (get-id)
|
||||
(track-store-id stored))
|
||||
|
||||
(define/public (get-number)
|
||||
(if track
|
||||
(send track get-number)
|
||||
(track-store-number stored)))
|
||||
|
||||
(define/public (get-title)
|
||||
(if track
|
||||
(send track get-title)
|
||||
(track-store-title stored)))
|
||||
|
||||
(define/public (get-artist)
|
||||
(if track
|
||||
(send track get-artist)
|
||||
""))
|
||||
|
||||
(define/public (get-album)
|
||||
(if track
|
||||
(send track get-album)
|
||||
""))
|
||||
|
||||
(define/public (get-length)
|
||||
(if track
|
||||
(send track get-length)
|
||||
0))
|
||||
|
||||
(define/public (->store)
|
||||
stored)
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define (track->playlist-entry track)
|
||||
(check/c track->playlist-entry
|
||||
track
|
||||
(is-a?/c track<%>))
|
||||
|
||||
(new playlist-entry%
|
||||
[stored (track->store track)]
|
||||
[track track]))
|
||||
|
||||
(define (store->playlist-entry stored factory)
|
||||
(check/c store->playlist-entry
|
||||
factory
|
||||
(is-a?/c library-factory%))
|
||||
|
||||
(and (track-store? stored)
|
||||
(new playlist-entry%
|
||||
[stored stored]
|
||||
[track (store->track stored factory)])))
|
||||
|
||||
(module+ test
|
||||
(require rackunit
|
||||
"../library/library-ref.rkt"
|
||||
"../library/track-filesystem.rkt")
|
||||
|
||||
(define stored
|
||||
(list 'track
|
||||
1
|
||||
'playlist-track
|
||||
3
|
||||
"Stored title"
|
||||
(library-ref
|
||||
'test-library
|
||||
'filesystem
|
||||
1)
|
||||
'file
|
||||
(list (string->path "track.mp3"))))
|
||||
|
||||
(define invalid-entry
|
||||
(new playlist-entry%
|
||||
[stored stored]))
|
||||
|
||||
(check-false (send invalid-entry is-valid?))
|
||||
(check-false (send invalid-entry get-track))
|
||||
(check-equal? (send invalid-entry get-id)
|
||||
'playlist-track)
|
||||
(check-equal? (send invalid-entry get-number) 3)
|
||||
(check-equal? (send invalid-entry get-title)
|
||||
"Stored title")
|
||||
(check-equal? (send invalid-entry get-artist) "")
|
||||
(check-equal? (send invalid-entry get-album) "")
|
||||
(check-equal? (send invalid-entry get-length) 0)
|
||||
(check-equal? (send invalid-entry ->store)
|
||||
stored)
|
||||
|
||||
(define cfg%
|
||||
(class object%
|
||||
(define/public (get-id) 'test-library)
|
||||
(define/public (get-kind) 'filesystem)
|
||||
(define/public (get-kind-version) 1)
|
||||
(super-new)))
|
||||
|
||||
(define library%
|
||||
(class object%
|
||||
(define/public (resolve-path relative-path)
|
||||
(apply build-path relative-path))
|
||||
(define/public (get-cfg)
|
||||
(new cfg%))
|
||||
(super-new)))
|
||||
|
||||
(define track
|
||||
(new track-filesystem%
|
||||
[library (new library%)]
|
||||
[relative-path
|
||||
(list (string->path "track.mp3"))]))
|
||||
|
||||
(define valid-entry
|
||||
(track->playlist-entry track))
|
||||
|
||||
(check-true (send valid-entry is-valid?))
|
||||
(check-eq? (send valid-entry get-track) track)
|
||||
(check-equal? (send valid-entry get-title)
|
||||
(send track get-title))
|
||||
(check-true
|
||||
(track-store?
|
||||
(send valid-entry ->store))))
|
||||
@@ -0,0 +1,218 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket-sprintf
|
||||
racket/string
|
||||
racket-webview
|
||||
xml
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide playlist-gui%)
|
||||
|
||||
(define (track-length->string length-seconds)
|
||||
(let* ((whole-seconds
|
||||
(inexact->exact
|
||||
(round length-seconds)))
|
||||
(hours (quotient whole-seconds 3600))
|
||||
(minutes
|
||||
(quotient (remainder whole-seconds 3600)
|
||||
60))
|
||||
(seconds
|
||||
(remainder (remainder whole-seconds 3600)
|
||||
60)))
|
||||
(sprintf "%02d:%02d:%02d"
|
||||
hours minutes seconds)))
|
||||
|
||||
(define (entry-tooltip entry)
|
||||
(let* ((track (send entry get-track))
|
||||
(uri
|
||||
(and track
|
||||
(send (send track get-resource)
|
||||
get-uri))))
|
||||
(string-join
|
||||
(filter
|
||||
(lambda (value)
|
||||
(and (string? value)
|
||||
(not (string=? value ""))))
|
||||
(list
|
||||
(send entry get-title)
|
||||
(send entry get-artist)
|
||||
(send entry get-album)
|
||||
uri
|
||||
(and (eq? (send entry get-cache-status)
|
||||
'failed)
|
||||
(send entry get-cache-error))))
|
||||
"\n")))
|
||||
|
||||
(define (track-row playlist track-idx current-track-nr)
|
||||
(let* ((entry (send playlist entry track-idx))
|
||||
(track-id (send playlist track-id track-idx))
|
||||
(row-class
|
||||
(cond
|
||||
((not (send entry is-valid?))
|
||||
"track invalid")
|
||||
((not (send entry is-available?))
|
||||
(format "track unavailable ~a"
|
||||
(send entry get-cache-status)))
|
||||
((equal? track-idx current-track-nr)
|
||||
"track current")
|
||||
(else "track"))))
|
||||
(list
|
||||
'tr
|
||||
(list (list 'id (format "~a" track-id))
|
||||
(list 'class row-class)
|
||||
(list 'title (entry-tooltip entry))
|
||||
(list 'draggable "true"))
|
||||
(list 'td
|
||||
'((class "number"))
|
||||
(format "~a." (send entry get-number)))
|
||||
(list 'td
|
||||
'((class "title"))
|
||||
(send entry get-title))
|
||||
(list 'td
|
||||
'((class "album"))
|
||||
(send entry get-album))
|
||||
(list 'td
|
||||
'((class "length"))
|
||||
(track-length->string
|
||||
(send entry get-length))))))
|
||||
|
||||
(define (playlist->html playlist current-track-nr)
|
||||
(xexpr->string
|
||||
(append
|
||||
(list 'table '((class "tracks")))
|
||||
(for/list ((track-idx
|
||||
(in-range (send playlist length))))
|
||||
(track-row playlist
|
||||
track-idx
|
||||
current-track-nr))
|
||||
(list
|
||||
(list 'tr '((class "unresponsive")))))))
|
||||
|
||||
(define playlist-gui%
|
||||
(class object%
|
||||
(init-field
|
||||
window
|
||||
element
|
||||
play-track-callback
|
||||
playlist-changed-callback)
|
||||
|
||||
(check/c* playlist-gui%
|
||||
(window object?)
|
||||
(element object?)
|
||||
(play-track-callback procedure?)
|
||||
(playlist-changed-callback procedure?))
|
||||
|
||||
(define dragged-from-idx
|
||||
#f)
|
||||
|
||||
(define/private (row-index playlist element)
|
||||
(send playlist
|
||||
index
|
||||
(send element attr/symbol 'id)))
|
||||
|
||||
(define/private (bind-row-events! playlist)
|
||||
(send window
|
||||
bind!
|
||||
"table.tracks tr.track"
|
||||
'(click contextmenu)
|
||||
(lambda (row event data)
|
||||
(case event
|
||||
((click)
|
||||
(let ((track-idx
|
||||
(row-index playlist row)))
|
||||
(when (send (send playlist entry track-idx)
|
||||
is-available?)
|
||||
(play-track-callback track-idx))))
|
||||
((contextmenu)
|
||||
(let* ((track-id (send row id))
|
||||
(menu
|
||||
(wv-menu
|
||||
'track-menu
|
||||
(wv-menu-item
|
||||
'm-drop-track
|
||||
"Drop track"
|
||||
#:callback
|
||||
(lambda ()
|
||||
(send playlist drop-id track-id)
|
||||
(playlist-changed-callback)))))
|
||||
(client-x (hash-ref data 'clientX 60))
|
||||
(client-y (hash-ref data 'clientY 60)))
|
||||
(send window
|
||||
popup-menu!
|
||||
menu
|
||||
client-x
|
||||
client-y))))))
|
||||
|
||||
(send window
|
||||
bind!
|
||||
"table.tracks tr.track"
|
||||
'dragstart
|
||||
(lambda (row event data)
|
||||
(set! dragged-from-idx
|
||||
(row-index playlist row)))
|
||||
#t)
|
||||
|
||||
(send window
|
||||
bind!
|
||||
"table.tracks tr.track"
|
||||
'(dragover drop)
|
||||
(lambda (row event data)
|
||||
(when (eq? event 'drop)
|
||||
(let ((drop-at-idx
|
||||
(row-index playlist row)))
|
||||
(when (and (integer? dragged-from-idx)
|
||||
(integer? drop-at-idx)
|
||||
(not (= dragged-from-idx
|
||||
drop-at-idx)))
|
||||
(send playlist
|
||||
move-track
|
||||
dragged-from-idx
|
||||
drop-at-idx)
|
||||
(set! dragged-from-idx #f)
|
||||
(playlist-changed-callback)))))))
|
||||
|
||||
(define/public (update! playlist current-track-nr)
|
||||
(let ((html
|
||||
(playlist->html playlist
|
||||
current-track-nr)))
|
||||
(send element set-innerHTML! html)
|
||||
(bind-row-events! playlist)
|
||||
(void)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define test-entry%
|
||||
(class object%
|
||||
(define/public (is-valid?) #t)
|
||||
(define/public (get-number) 3)
|
||||
(define/public (get-title) "Title")
|
||||
(define/public (get-artist) "Artist")
|
||||
(define/public (get-album) "Album")
|
||||
(define/public (get-length) 65)
|
||||
(define/public (get-track) #f)
|
||||
(define/public (get-cache-status) 'available)
|
||||
(define/public (get-cache-error) #f)
|
||||
(define/public (is-available?) #t)
|
||||
(super-new)))
|
||||
|
||||
(define test-playlist%
|
||||
(class object%
|
||||
(define/public (length) 1)
|
||||
(define/public (entry idx)
|
||||
(new test-entry%))
|
||||
(define/public (track-id idx)
|
||||
'track-1)
|
||||
(super-new)))
|
||||
|
||||
(define html
|
||||
(playlist->html (new test-playlist%) 0))
|
||||
|
||||
(check-true (string-contains? html "track current"))
|
||||
(check-true (string-contains? html "draggable"))
|
||||
(check-true (string-contains? html "00:01:05"))
|
||||
(check-equal? (track-length->string 1365.797)
|
||||
"00:22:46"))
|
||||
@@ -0,0 +1,487 @@
|
||||
#lang racket/base
|
||||
|
||||
(require keystore/class
|
||||
racket/class
|
||||
racket/list
|
||||
"../library/library-factory.rkt"
|
||||
"../library/base/media-item.rkt"
|
||||
"playlist-cache.rkt"
|
||||
"playlist-entry.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide playlist%)
|
||||
|
||||
(define list-length
|
||||
length)
|
||||
|
||||
(define list-for-each
|
||||
for-each)
|
||||
|
||||
(define (valid-track-index? entries idx)
|
||||
(and (exact-nonnegative-integer? idx)
|
||||
(< idx (list-length entries))
|
||||
(send (list-ref entries idx)
|
||||
is-valid?)))
|
||||
|
||||
(define (available-track-index? entries idx)
|
||||
(and (exact-nonnegative-integer? idx)
|
||||
(< idx (list-length entries))
|
||||
(send (list-ref entries idx)
|
||||
is-available?)))
|
||||
|
||||
(define (first-valid-index entries indexes)
|
||||
(for/first ((idx indexes)
|
||||
#:when
|
||||
(valid-track-index? entries idx))
|
||||
idx))
|
||||
|
||||
(define (first-available-index entries indexes)
|
||||
(for/first ((idx indexes)
|
||||
#:when
|
||||
(available-track-index? entries idx))
|
||||
idx))
|
||||
|
||||
(define playlist%
|
||||
(class object%
|
||||
(init-field
|
||||
[max-tracks 100]
|
||||
[name "Default"]
|
||||
[id #f]
|
||||
[settings #f]
|
||||
[cache-updated
|
||||
(lambda (entry downloaded total) (void))])
|
||||
|
||||
(check/c playlist% max-tracks exact-positive-integer?)
|
||||
|
||||
(define store
|
||||
(new keystore%
|
||||
[file 'rktplayer]))
|
||||
|
||||
(define entries
|
||||
'())
|
||||
|
||||
(define cache
|
||||
#f)
|
||||
|
||||
(define factory
|
||||
(get-library-factory))
|
||||
|
||||
(define/private (can-add?)
|
||||
(< (list-length entries)
|
||||
max-tracks))
|
||||
|
||||
(define/private (set-cache! playlist-id)
|
||||
(when cache
|
||||
(send cache stop!))
|
||||
(set! cache
|
||||
(new playlist-cache%
|
||||
[playlist-id playlist-id]
|
||||
[updated cache-updated]))
|
||||
(list-for-each
|
||||
(lambda (entry)
|
||||
(send cache ensure-entry! entry))
|
||||
entries))
|
||||
|
||||
(define/private (add-track* track)
|
||||
(when (can-add?)
|
||||
(let ((entry
|
||||
(track->playlist-entry track)))
|
||||
(set! entries
|
||||
(append entries
|
||||
(list entry)))
|
||||
(when cache
|
||||
(send cache ensure-entry! entry)))))
|
||||
|
||||
(define/private (add-media-item* item)
|
||||
(when (can-add?)
|
||||
(let ((track (send item get-track))
|
||||
(container (send item get-container)))
|
||||
(cond
|
||||
(track
|
||||
(add-track* track))
|
||||
(container
|
||||
(list-for-each
|
||||
(lambda (child)
|
||||
(add-media-item* child))
|
||||
(send container get-items)))))))
|
||||
|
||||
(define/private (sort-entries!)
|
||||
(set! entries
|
||||
(sort
|
||||
entries
|
||||
(lambda (entry-1 entry-2)
|
||||
(let ((track-1 (send entry-1 get-track))
|
||||
(track-2 (send entry-2 get-track)))
|
||||
(and track-1
|
||||
(or (not track-2)
|
||||
(send track-1
|
||||
track<
|
||||
track-2))))))))
|
||||
|
||||
(define/public (tabs)
|
||||
(map
|
||||
(lambda (key)
|
||||
(if (string? key)
|
||||
(string->symbol key)
|
||||
key))
|
||||
(send store
|
||||
get
|
||||
'tabs
|
||||
'(tabkey-default))))
|
||||
|
||||
(define/public (tab-count)
|
||||
(list-length (send this tabs)))
|
||||
|
||||
(define/public (make-tab-key)
|
||||
(string->symbol
|
||||
(format "tabkey-~a-~a"
|
||||
(current-milliseconds)
|
||||
(random 10000))))
|
||||
|
||||
(define/public (get-tab-name idx)
|
||||
(let* ((tabs (send this tabs))
|
||||
(tab-id (list-ref tabs idx))
|
||||
(stored
|
||||
(send store
|
||||
get
|
||||
tab-id
|
||||
(list
|
||||
(format "Playlist-~a" idx)
|
||||
'()))))
|
||||
(car stored)))
|
||||
|
||||
(define/public (set-tab-name! idx new-name)
|
||||
(check/c playlist% set-tab-name!
|
||||
new-name
|
||||
string?)
|
||||
|
||||
(let* ((tabs (send this tabs))
|
||||
(tab-id (list-ref tabs idx))
|
||||
(stored
|
||||
(send store
|
||||
get
|
||||
tab-id
|
||||
(list
|
||||
(format "Playlist-~a" idx)
|
||||
'()))))
|
||||
(send store
|
||||
set!
|
||||
tab-id
|
||||
(list new-name
|
||||
(cadr stored)))))
|
||||
|
||||
(define/public (tab-id idx)
|
||||
(list-ref (send this tabs)
|
||||
idx))
|
||||
|
||||
(define/public (tab-index tab-id)
|
||||
(index-of (send this tabs)
|
||||
tab-id
|
||||
eq?))
|
||||
|
||||
(define/public (drop-tab! idx)
|
||||
(let* ((tabs (send this tabs))
|
||||
(tab-id (list-ref tabs idx)))
|
||||
(when (eq? id tab-id)
|
||||
(when cache
|
||||
(send cache stop!))
|
||||
(set! cache #f))
|
||||
(clear-playlist-cache! tab-id)
|
||||
(send store
|
||||
set!
|
||||
'tabs
|
||||
(list-drop! tabs idx))
|
||||
(send store drop! tab-id)))
|
||||
|
||||
(define/public (add-tab!)
|
||||
(let ((tab-id (send this make-tab-key)))
|
||||
(send store
|
||||
set!
|
||||
'tabs
|
||||
(append (send this tabs)
|
||||
(list tab-id)))))
|
||||
|
||||
(define/public (save-tab!)
|
||||
(let ((idx (send this tab-index id)))
|
||||
(dbg-rktplayer "entry id = ~a, ~a" id idx)
|
||||
(if idx
|
||||
(send store
|
||||
set!
|
||||
id
|
||||
(list
|
||||
(send this get-tab-name idx)
|
||||
(map
|
||||
(lambda (entry)
|
||||
(send entry ->store))
|
||||
entries)))
|
||||
(err-rktplayer
|
||||
"Cannot get tab for id ~a"
|
||||
id))))
|
||||
|
||||
(define/public (load-tab idx)
|
||||
(let* ((tabs (send this tabs))
|
||||
(tab-id (list-ref tabs idx))
|
||||
(stored
|
||||
(send store
|
||||
get
|
||||
tab-id
|
||||
(list "Default" '()))))
|
||||
(dbg-rktplayer "loading ~a" tab-id)
|
||||
(set! id tab-id)
|
||||
(set! name (car stored))
|
||||
(set! entries
|
||||
(filter-map
|
||||
(lambda (stored-track)
|
||||
(store->playlist-entry
|
||||
stored-track
|
||||
factory))
|
||||
(cadr stored)))
|
||||
(set-cache! tab-id))
|
||||
#t)
|
||||
|
||||
(define/public (length)
|
||||
(list-length entries))
|
||||
|
||||
(define/public (first-valid-track-index)
|
||||
(first-valid-index
|
||||
entries
|
||||
(in-range (list-length entries))))
|
||||
|
||||
(define/public (first-available-track-index)
|
||||
(first-available-index
|
||||
entries
|
||||
(in-range (list-length entries))))
|
||||
|
||||
(define/public (next-valid-track-index idx
|
||||
[wrap? #f])
|
||||
(check/c* (playlist% next-valid-track-index)
|
||||
(idx exact-nonnegative-integer?)
|
||||
(wrap? boolean?))
|
||||
|
||||
(or
|
||||
(first-valid-index
|
||||
entries
|
||||
(in-range (+ idx 1)
|
||||
(list-length entries)))
|
||||
(and wrap?
|
||||
(first-valid-index
|
||||
entries
|
||||
(in-range
|
||||
(min (+ idx 1)
|
||||
(list-length entries)))))))
|
||||
|
||||
(define/public (next-available-track-index idx
|
||||
[wrap? #f])
|
||||
(check/c* (playlist% next-available-track-index)
|
||||
(idx exact-nonnegative-integer?)
|
||||
(wrap? boolean?))
|
||||
|
||||
(or
|
||||
(first-available-index
|
||||
entries
|
||||
(in-range (+ idx 1)
|
||||
(list-length entries)))
|
||||
(and wrap?
|
||||
(first-available-index
|
||||
entries
|
||||
(in-range
|
||||
(min (+ idx 1)
|
||||
(list-length entries)))))))
|
||||
|
||||
(define/public (previous-valid-track-index idx
|
||||
[wrap? #f])
|
||||
(check/c* (playlist% previous-valid-track-index)
|
||||
(idx exact-nonnegative-integer?)
|
||||
(wrap? boolean?))
|
||||
|
||||
(or
|
||||
(first-valid-index
|
||||
entries
|
||||
(in-range (- idx 1)
|
||||
-1
|
||||
-1))
|
||||
(and wrap?
|
||||
(first-valid-index
|
||||
entries
|
||||
(in-range
|
||||
(- (list-length entries) 1)
|
||||
(- idx 1)
|
||||
-1)))))
|
||||
|
||||
(define/public (previous-available-track-index idx
|
||||
[wrap? #f])
|
||||
(check/c* (playlist% previous-available-track-index)
|
||||
(idx exact-nonnegative-integer?)
|
||||
(wrap? boolean?))
|
||||
|
||||
(or
|
||||
(first-available-index
|
||||
entries
|
||||
(in-range (- idx 1)
|
||||
-1
|
||||
-1))
|
||||
(and wrap?
|
||||
(first-available-index
|
||||
entries
|
||||
(in-range
|
||||
(- (list-length entries) 1)
|
||||
(- idx 1)
|
||||
-1)))))
|
||||
|
||||
(define/public (add-track track . save?)
|
||||
(add-track* track)
|
||||
(when (null? save?)
|
||||
(send this save-tab!)))
|
||||
|
||||
(define/public (add-media-item item . save?)
|
||||
(check/c playlist% add-media-item
|
||||
item
|
||||
(is-a?/c media-item%))
|
||||
|
||||
(add-media-item* item)
|
||||
(when (null? save?)
|
||||
(send this save-tab!)))
|
||||
|
||||
(define/public (replace-with-media-item! item)
|
||||
(check/c playlist% replace-with-media-item!
|
||||
item
|
||||
(is-a?/c media-item%))
|
||||
|
||||
(when cache
|
||||
(send cache stop!))
|
||||
(clear-playlist-cache! id)
|
||||
(set! entries '())
|
||||
(set! cache #f)
|
||||
(set-cache! id)
|
||||
(add-media-item* item)
|
||||
(sort-entries!)
|
||||
(send this save-tab!))
|
||||
|
||||
(define/public (move-track from-idx to-idx)
|
||||
(unless (= from-idx to-idx)
|
||||
(let* ((entry (list-ref entries from-idx))
|
||||
(target-idx
|
||||
(if (< from-idx to-idx)
|
||||
(- to-idx 1)
|
||||
to-idx))
|
||||
(without-entry
|
||||
(append
|
||||
(take entries from-idx)
|
||||
(drop entries (+ from-idx 1)))))
|
||||
(set! entries
|
||||
(append
|
||||
(take without-entry target-idx)
|
||||
(list entry)
|
||||
(drop without-entry target-idx)))
|
||||
(send this save-tab!))))
|
||||
|
||||
(define/public (drop-id track-id)
|
||||
(let* ((idx (send this index track-id))
|
||||
(entry (list-ref entries idx)))
|
||||
(set! entries
|
||||
(append
|
||||
(take entries idx)
|
||||
(drop entries (+ idx 1))))
|
||||
(when (and cache
|
||||
(not
|
||||
(findf
|
||||
(lambda (other)
|
||||
(equal? (send other get-id)
|
||||
(send entry get-id)))
|
||||
entries)))
|
||||
(send cache drop-entry! entry))
|
||||
(send this save-tab!)))
|
||||
|
||||
(define/public (entry idx)
|
||||
(list-ref entries idx))
|
||||
|
||||
(define/public (track idx)
|
||||
(send (send this entry idx)
|
||||
get-track))
|
||||
|
||||
(define/public (track-file idx)
|
||||
(send (send this entry idx)
|
||||
get-cache-file))
|
||||
|
||||
(define/public (cache-all!)
|
||||
(when cache
|
||||
(list-for-each
|
||||
(lambda (entry)
|
||||
(send cache ensure-entry! entry))
|
||||
entries)))
|
||||
|
||||
(define/public (reset-cache!)
|
||||
(when cache
|
||||
(send cache stop!))
|
||||
(clear-playlist-cache!)
|
||||
(set! cache #f)
|
||||
(set-cache! id))
|
||||
|
||||
(define/public (stop-cache!)
|
||||
(when cache
|
||||
(send cache stop!)
|
||||
(set! cache #f)))
|
||||
|
||||
(define/public (display-tracks)
|
||||
(list-for-each
|
||||
(lambda (entry)
|
||||
(let ((track (send entry get-track)))
|
||||
(if track
|
||||
(send track ->log)
|
||||
(warn-rktplayer
|
||||
"Unavailable track: ~a"
|
||||
(send entry get-title)))))
|
||||
entries))
|
||||
|
||||
(define/public (for-each proc)
|
||||
(for ((entry (in-list entries))
|
||||
(idx (in-naturals)))
|
||||
(proc idx
|
||||
(send entry get-track))))
|
||||
|
||||
(define/public (track-id idx)
|
||||
(string->symbol
|
||||
(format "track-~a"
|
||||
(+ idx 1))))
|
||||
|
||||
(define/public (index track-id)
|
||||
(- (string->number
|
||||
(substring
|
||||
(symbol->string track-id)
|
||||
6))
|
||||
1))
|
||||
|
||||
(super-new)
|
||||
|
||||
(send this load-tab 0)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define test-entry%
|
||||
(class object%
|
||||
(init-field valid?)
|
||||
(define/public (is-valid?) valid?)
|
||||
(define/public (is-available?) valid?)
|
||||
(super-new)))
|
||||
|
||||
(define entries
|
||||
(list
|
||||
(new test-entry% [valid? #f])
|
||||
(new test-entry% [valid? #t])
|
||||
(new test-entry% [valid? #f])
|
||||
(new test-entry% [valid? #t])))
|
||||
|
||||
(check-equal?
|
||||
(first-valid-index
|
||||
entries
|
||||
(in-range (list-length entries)))
|
||||
1)
|
||||
(check-equal?
|
||||
(first-valid-index entries (in-range 2 4))
|
||||
3)
|
||||
(check-false
|
||||
(first-valid-index entries (in-range 4 4)))
|
||||
(check-equal?
|
||||
(first-valid-index entries (in-range 2 -1 -1))
|
||||
1))
|
||||
@@ -0,0 +1,29 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket-sonos
|
||||
"renderer-upnp.rkt")
|
||||
|
||||
(provide renderer-sonos%)
|
||||
|
||||
(define renderer-sonos%
|
||||
(class renderer-upnp%
|
||||
(init-field sonos-group)
|
||||
(init preferences)
|
||||
|
||||
(define/public (get-sonos-group)
|
||||
sonos-group)
|
||||
|
||||
(super-new
|
||||
[upnp-device
|
||||
(sonos-group-renderer
|
||||
sonos-group)]
|
||||
[preferences preferences]
|
||||
[id
|
||||
(format "sonos:~a"
|
||||
(sonos-group-id
|
||||
sonos-group))]
|
||||
[name
|
||||
(sonos-group-name
|
||||
sonos-group)]
|
||||
[kind 'sonos])))
|
||||
@@ -0,0 +1,35 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket-upnp
|
||||
"base/renderer.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide renderer-upnp%)
|
||||
|
||||
(define renderer-upnp%
|
||||
(class renderer%
|
||||
(init-field upnp-device)
|
||||
(init
|
||||
preferences
|
||||
[name #f]
|
||||
[id #f]
|
||||
[kind 'upnp])
|
||||
|
||||
(check/c renderer-upnp%
|
||||
upnp-device
|
||||
media-renderer?)
|
||||
|
||||
(super-new
|
||||
[id
|
||||
(format "~a"
|
||||
(or id
|
||||
(upnp-device-udn upnp-device)
|
||||
(upnp-device-address
|
||||
upnp-device)))]
|
||||
[name
|
||||
(or name
|
||||
(media-renderer-name upnp-device))]
|
||||
[kind kind]
|
||||
[device upnp-device]
|
||||
[preferences preferences])))
|
||||
Reference in New Issue
Block a user