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:
@@ -20,3 +20,4 @@ compiled/
|
||||
|
||||
/*.bak
|
||||
/gui/*.bak
|
||||
/gui/html/*.bak
|
||||
|
||||
@@ -0,0 +1,10 @@
|
||||
# Project coding style
|
||||
|
||||
- Follow the existing Racket style demonstrated in library-factory.rkt.
|
||||
- Use define primarily for module definitions, class state, and methods.
|
||||
- Use let and let* for method-local values and keep related operations in the same lexical scope.
|
||||
- Prefer explicit intermediate names, such as maker-key, when they clarify intent.
|
||||
- Keep implementations small and direct; avoid unnecessary helper layers.
|
||||
- Validate each invariant in one appropriate place. Do not duplicate constructor checks in callers or deserializers.
|
||||
- Use check/c and check/c* from utils.rkt for concise argument validation where validation is needed.
|
||||
- Preserve the surrounding formatting and naming style when modifying existing code.
|
||||
-373
@@ -1,373 +0,0 @@
|
||||
#lang racket
|
||||
|
||||
(require racket/class
|
||||
racket/path
|
||||
(prefix-in rad: racket-audio-dlna)
|
||||
"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)]
|
||||
[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 stop-requested? #f)
|
||||
(define stopped-polls 0)
|
||||
(define renderer-reachable? #t)
|
||||
(define running #t)
|
||||
(define poll-thread #f)
|
||||
|
||||
(define (check-player)
|
||||
(when (eq? renderer #f)
|
||||
(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
|
||||
renderer
|
||||
#:listen-ip listen-ip
|
||||
#:port server-port
|
||||
#:path "/rktplayer/"
|
||||
#:poll-seconds poll-seconds
|
||||
#:volume-poll-seconds volume-poll-seconds))))
|
||||
|
||||
(define (normalize-state st)
|
||||
(cond
|
||||
[(or (eq? st 'playing)
|
||||
(eq? st 'transitioning))
|
||||
'playing]
|
||||
[(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 ((match
|
||||
(and file
|
||||
(regexp-match
|
||||
#px"(?i:[.]([a-z0-9]+))$"
|
||||
(path->string file)))))
|
||||
(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)
|
||||
(send (send playlist track nr) get-file))
|
||||
|
||||
(define (playlist-track-nr file)
|
||||
(and playlist
|
||||
(for/first ([nr (in-range (send playlist length))]
|
||||
#:when (same-file? file (playlist-track-file nr)))
|
||||
nr)))
|
||||
|
||||
(define (next-track-nr nr)
|
||||
(let ((length (send playlist length)))
|
||||
(cond
|
||||
[(eq? repeat 'repeat-one) nr]
|
||||
[(eq? repeat 'repeat-all)
|
||||
(if (= (+ nr 1) length) 0 (+ nr 1))]
|
||||
[(< (+ nr 1) length) (+ nr 1)]
|
||||
[else #f])))
|
||||
|
||||
(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))
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (e)
|
||||
(set! prepared-next-track-nr #f)
|
||||
(warn-rktplayer
|
||||
"Could not prepare next DLNA track: ~a"
|
||||
(exn-message e)))])
|
||||
(rad:dlna-player-set-next-file!
|
||||
player
|
||||
(playlist-track-file 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)))
|
||||
(nr (cond
|
||||
[(and (exact-nonnegative-integer?
|
||||
prepared-next-track-nr)
|
||||
(same-file?
|
||||
file
|
||||
(playlist-track-file prepared-next-track-nr)))
|
||||
prepared-next-track-nr]
|
||||
[else (playlist-track-nr file)])))
|
||||
(when (exact-nonnegative-integer? nr)
|
||||
(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"))
|
||||
(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)))
|
||||
(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 'paused))
|
||||
(when (and (number? position)
|
||||
(number? duration))
|
||||
(time-updater position duration))
|
||||
(track-audio-info! (rad:dlna-info-track info)))
|
||||
|
||||
(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?)
|
||||
(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! 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)
|
||||
(or (rad:dlna-info-volume
|
||||
(rad:dlna-player-info player))
|
||||
0))
|
||||
|
||||
(define/public (set-volume! percentage)
|
||||
(check-player)
|
||||
(rad:dlna-player-volume! player 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! 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*)
|
||||
(send this play-track 0))
|
||||
|
||||
(define/public (play-track nr)
|
||||
(check-player)
|
||||
(when (and playlist
|
||||
(>= nr 0)
|
||||
(< nr (send playlist length)))
|
||||
(let ((file (playlist-track-file nr)))
|
||||
(rad:dlna-player-play! player file)
|
||||
(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! stop-requested? #f)
|
||||
(set! stopped-polls 0)
|
||||
(track-nr-updater nr)
|
||||
(track-audio-info! (rad:dlna-info-track info))
|
||||
(set-state! 'playing)
|
||||
(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))
|
||||
(cond
|
||||
[(eq? repeat 'repeat-one)
|
||||
(send this play-track nr)]
|
||||
[(eq? repeat 'repeat-all)
|
||||
(send this play-track
|
||||
(if (= nr 0)
|
||||
(- (send playlist length) 1)
|
||||
(- nr 1)))]
|
||||
[else
|
||||
(send this play-track (max 0 (- nr 1)))]))))
|
||||
|
||||
(define/public (pause!)
|
||||
(check-player)
|
||||
(rad:dlna-player-pause! player)
|
||||
(set-state! 'paused))
|
||||
|
||||
(define/public (play!)
|
||||
(check-player)
|
||||
(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)
|
||||
(check-player)
|
||||
(set! stop-requested? #t)
|
||||
(set! playing-seen? #f)
|
||||
(set! stopped-polls 0)
|
||||
(rad:dlna-player-stop! player)
|
||||
(set-state! 'stopped))
|
||||
|
||||
(define/public (seek percentage)
|
||||
(check-player)
|
||||
(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"))))
|
||||
@@ -1,40 +0,0 @@
|
||||
#lang racket
|
||||
|
||||
(require racket-upnp)
|
||||
|
||||
(provide check-dlna-players)
|
||||
|
||||
(define running-sem (make-semaphore 1))
|
||||
(define running #f)
|
||||
|
||||
(define (check-dlna-players gui)
|
||||
(let ((can-check (begin
|
||||
(semaphore-wait running-sem)
|
||||
(let ((rng running))
|
||||
(if rng
|
||||
(begin
|
||||
(semaphore-post running-sem)
|
||||
#f)
|
||||
(begin
|
||||
(set! running #t)
|
||||
(semaphore-post running-sem)
|
||||
#t))))))
|
||||
(if can-check
|
||||
(void
|
||||
(thread
|
||||
(λ ()
|
||||
(let ((r (query-media-renderers)))
|
||||
(let ((r* (map (λ (r)
|
||||
(list (media-renderer-name r)
|
||||
r))
|
||||
r)))
|
||||
(send gui set-dlna-renderers! r*)
|
||||
(semaphore-wait running-sem)
|
||||
(set! running #f)
|
||||
(semaphore-post running-sem)
|
||||
)))))
|
||||
(void
|
||||
(send gui dlna-query-busy))
|
||||
)
|
||||
)
|
||||
)
|
||||
+573
-209
@@ -6,15 +6,20 @@
|
||||
racket-sprintf
|
||||
open-app
|
||||
xml
|
||||
"utils.rkt"
|
||||
"music-library.rkt"
|
||||
"../misc/utils.rkt"
|
||||
"translate.rkt"
|
||||
"playlist.rkt"
|
||||
"player.rkt"
|
||||
"dlna-player.rkt"
|
||||
"../play/playlist.rkt"
|
||||
"../play/playlist-gui.rkt"
|
||||
"../play/base/player.rkt"
|
||||
"../play/dlna-player.rkt"
|
||||
"settings.rkt"
|
||||
"libraries.rkt"
|
||||
"dlna.rkt"
|
||||
"../library/libraries-config.rkt"
|
||||
"../library/library-browser.rkt"
|
||||
"../library/library-factory.rkt"
|
||||
"../library/library-ref.rkt"
|
||||
"../library/base/media-resource.rkt"
|
||||
"../play/base/renderer.rkt"
|
||||
"../play/dlna.rkt"
|
||||
)
|
||||
|
||||
(provide
|
||||
@@ -22,15 +27,30 @@
|
||||
rktplayer%
|
||||
)
|
||||
|
||||
(define-runtime-path rkt-gui-dir "gui")
|
||||
(define-runtime-path rkt-gui-dir "html")
|
||||
|
||||
|
||||
(define (checked-title title checked?)
|
||||
(if checked?
|
||||
(format "✓ ~a" title)
|
||||
title))
|
||||
|
||||
(define (media-item-formatter row)
|
||||
(let ((item-id (car row))
|
||||
(title (cadr row)))
|
||||
(list
|
||||
(list 'td
|
||||
(list (list 'class "library-entry")
|
||||
(list 'id (format "item-~a" item-id))
|
||||
(list 'item-id item-id))
|
||||
title))))
|
||||
|
||||
(define player-menu
|
||||
(λ (renderers connector)
|
||||
(λ (renderers libraries current-player-id current-library-id
|
||||
player-connector library-connector)
|
||||
(wv-menu 'main-menu
|
||||
(wv-menu-item 'm-file (tr 'file)
|
||||
#:submenu (wv-menu 'file-menu
|
||||
(wv-menu-item 'm-select-library-dir (tr 'select-library-dir))
|
||||
(wv-menu-item 'm-settings (tr 'settings))
|
||||
(wv-menu-item 'm-quit (tr 'quit) #:separator #t)
|
||||
))
|
||||
@@ -38,7 +58,11 @@
|
||||
#:submenu (apply wv-menu
|
||||
(append
|
||||
(list 'dlna-menu
|
||||
(wv-menu-item 'm-play-local (tr 'play-local))
|
||||
(wv-menu-item 'm-play-local
|
||||
(checked-title
|
||||
(tr 'play-local)
|
||||
(eq? current-player-id
|
||||
'm-play-local)))
|
||||
(wv-menu-item 'm-check-dlna (tr 'check-dlna)))
|
||||
(let ((rndr-idx 0))
|
||||
(map (λ (r)
|
||||
@@ -46,12 +70,38 @@
|
||||
(id (string->symbol
|
||||
(format "m-renderer-~a" idx))))
|
||||
(set! rndr-idx (+ rndr-idx 1))
|
||||
(connector id idx)
|
||||
(wv-menu-item id (car r) #:separator (= idx 0))))
|
||||
renderers))))
|
||||
)
|
||||
(player-connector id idx)
|
||||
(wv-menu-item
|
||||
id
|
||||
(checked-title
|
||||
(send r get-name)
|
||||
(eq? current-player-id id))
|
||||
#:separator (= idx 0))))
|
||||
renderers)))))
|
||||
(wv-menu-item 'm-libraries (tr 'libraries)
|
||||
#:submenu
|
||||
(apply wv-menu
|
||||
(cons
|
||||
'libraries-menu
|
||||
(let ((library-idx 0))
|
||||
(map
|
||||
(lambda (cfg)
|
||||
(let* ((idx library-idx)
|
||||
(id (string->symbol
|
||||
(format "m-library-~a" idx))))
|
||||
(set! library-idx (+ library-idx 1))
|
||||
(library-connector id idx)
|
||||
(wv-menu-item
|
||||
id
|
||||
(checked-title
|
||||
(send cfg get-name)
|
||||
(eq? current-library-id
|
||||
(send cfg get-id))))))
|
||||
libraries)))))
|
||||
)))
|
||||
|
||||
(define application-title "Racket Music Player")
|
||||
|
||||
(define rktplayer%
|
||||
(class wv-window%
|
||||
(init-field [log-file #f])
|
||||
@@ -59,7 +109,7 @@
|
||||
|
||||
(super-new
|
||||
[html-path "rktplayer.html"]
|
||||
[title "Racket Music Player"]
|
||||
[title application-title]
|
||||
[icon (build-path rkt-gui-dir "rktplayer.png")]
|
||||
[quit-on-close #f]
|
||||
)
|
||||
@@ -72,10 +122,12 @@
|
||||
(define el-vol-perc #f)
|
||||
(define el-library #f)
|
||||
(define el-playlist #f)
|
||||
(define playlist-gui #f)
|
||||
(define el-at #f)
|
||||
(define el-length #f)
|
||||
(define el-rate #f)
|
||||
(define el-format #f)
|
||||
(define el-source #f)
|
||||
(define el-channels #f)
|
||||
(define el-bits #f)
|
||||
(define el-message #f)
|
||||
@@ -83,19 +135,22 @@
|
||||
|
||||
(define current-tab 0)
|
||||
|
||||
(define music-library
|
||||
(let* ((libs (new libraries% [settings cfg]))
|
||||
(lib (send libs current-library))
|
||||
(dir (if (eq? lib #f)
|
||||
(find-system-path 'home-dir)
|
||||
(send lib get-local-path)))
|
||||
(path (format "~a" dir)))
|
||||
(when (eq? (system-type 'os) 'windows)
|
||||
(set! path (string-replace path "/" "\\")))
|
||||
(dbg-rktplayer "music-library: ~a" path)
|
||||
path))
|
||||
(define library-factory
|
||||
(get-library-factory))
|
||||
|
||||
(define libraries-config
|
||||
(send library-factory
|
||||
get-libraries-config))
|
||||
|
||||
(define library-browser #f)
|
||||
|
||||
(define library-items
|
||||
(make-hash))
|
||||
|
||||
;; A browse request can finish after another library or container has
|
||||
;; already been selected. Only the most recent request may update the GUI.
|
||||
(define library-update-request 0)
|
||||
|
||||
(define current-music-path #f)
|
||||
(define playlist #f)
|
||||
|
||||
(define current-at-seconds 0)
|
||||
@@ -139,11 +194,20 @@
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (message! msg #:clear [clear #f])
|
||||
(define/public (message! msg
|
||||
#:clear [clear #f]
|
||||
#:error [error #f])
|
||||
(when (eq? el-message #f)
|
||||
(set! el-message (send this element 'message)))
|
||||
(unless (eq? el-message #f)
|
||||
(send el-message set-innerHTML! msg)
|
||||
(send el-message
|
||||
set-innerHTML!
|
||||
(if error
|
||||
(list
|
||||
'span
|
||||
'((class "blink error"))
|
||||
msg)
|
||||
msg))
|
||||
(when clear
|
||||
(void
|
||||
(thread (λ ()
|
||||
@@ -151,9 +215,109 @@
|
||||
(send this message! "" #:clear #f)))))
|
||||
))
|
||||
|
||||
(define/private (track-source track)
|
||||
(let* ((reference
|
||||
(send track
|
||||
get-music-library-factory-id))
|
||||
(library
|
||||
(and (library-ref? reference)
|
||||
(send libraries-config
|
||||
get-library
|
||||
(library-ref-library-id
|
||||
reference)))))
|
||||
(and library
|
||||
(send library get-name))))
|
||||
|
||||
(define/private (update-track-source! track)
|
||||
(when el-source
|
||||
(if track
|
||||
(let* ((resource (send track get-resource))
|
||||
(uri (send resource get-uri))
|
||||
(source
|
||||
(or (track-source track)
|
||||
uri)))
|
||||
(send el-source
|
||||
set-innerHTML!
|
||||
(xexpr->string
|
||||
(list
|
||||
'span
|
||||
(list (list 'title uri))
|
||||
(format "~a: ~a"
|
||||
(tr 'source)
|
||||
source)))))
|
||||
(send el-source set-innerHTML! ""))))
|
||||
|
||||
(define (cache-updated entry downloaded total)
|
||||
(when (and page-ready
|
||||
(not closed))
|
||||
(let ((status (send entry get-cache-status)))
|
||||
(case status
|
||||
((downloading)
|
||||
(send this
|
||||
message!
|
||||
(format
|
||||
(tr 'downloading-track)
|
||||
(send entry get-number)
|
||||
(if (and total (> total 0))
|
||||
(inexact->exact
|
||||
(round
|
||||
(* 100
|
||||
(/ downloaded total))))
|
||||
0))
|
||||
#:clear #t))
|
||||
((available)
|
||||
(send this update-playlist)
|
||||
(send this
|
||||
message!
|
||||
(format (tr 'download-track-complete)
|
||||
(send entry get-number)
|
||||
#:clear #t)))
|
||||
((failed)
|
||||
(send this update-playlist)
|
||||
(send this
|
||||
message!
|
||||
(format (tr 'download-track-failed)
|
||||
(send entry get-number))
|
||||
#:clear #t))
|
||||
))))
|
||||
|
||||
(define current-track-nr #f)
|
||||
|
||||
(define/private (popup-current-booklet evt)
|
||||
(when (and playlist
|
||||
(exact-nonnegative-integer?
|
||||
current-track-nr)
|
||||
(< current-track-nr
|
||||
(send playlist length)))
|
||||
(let ((track
|
||||
(send playlist
|
||||
track
|
||||
current-track-nr)))
|
||||
(when (and track
|
||||
(send track has-booklet?))
|
||||
(let ((menu
|
||||
(wv-menu
|
||||
'image-menu
|
||||
(wv-menu-item
|
||||
'm-booklet
|
||||
(tr 'open-booklet)
|
||||
#:callback
|
||||
(lambda ()
|
||||
(send this
|
||||
open-booklet
|
||||
(send track booklet-file)
|
||||
#t)))))
|
||||
(client-x (hash-ref evt 'clientX 60))
|
||||
(client-y (hash-ref evt 'clientY 60)))
|
||||
(send this
|
||||
popup-menu!
|
||||
menu
|
||||
client-x
|
||||
client-y))))))
|
||||
|
||||
(define (update-track-nr nr)
|
||||
(when (eq? nr #f)
|
||||
(update-track-source! #f))
|
||||
(unless (or (eq? playlist #f)
|
||||
(= (send playlist length) 0))
|
||||
(dbg-rktplayer "update-track-nr ~a" nr)
|
||||
@@ -167,6 +331,11 @@
|
||||
(send el remove-class! "current")))
|
||||
|
||||
(set! current-track-nr nr)
|
||||
(update-track-source!
|
||||
(and current-track-nr
|
||||
(send playlist
|
||||
track
|
||||
current-track-nr)))
|
||||
|
||||
(dbg-rktplayer "Adding current")
|
||||
(unless (eq? current-track-nr #f)
|
||||
@@ -189,16 +358,6 @@
|
||||
(current-milliseconds))))
|
||||
(dbg-rktplayer "Html = ~a" html)
|
||||
(send el set-innerHTML! html)
|
||||
(when (send track has-booklet?)
|
||||
(let ((booklet-file (send track booklet-file)))
|
||||
(send this bind! 'album-image 'contextmenu
|
||||
(λ (el evt data)
|
||||
(let ((mnu (wv-menu 'image-menu
|
||||
(wv-menu-item 'm-booklet (tr 'open-booklet)
|
||||
#:callback (λ () (send this open-booklet booklet-file #t)))))
|
||||
(clientX (hash-ref data 'clientX 60))
|
||||
(clientY (hash-ref data 'clientY 60)))
|
||||
(send this popup-menu! mnu clientX clientY))))))
|
||||
)))
|
||||
)
|
||||
)
|
||||
@@ -232,6 +391,11 @@
|
||||
((eq? st 'paused)
|
||||
(set-play-button "buttons/play.svg")
|
||||
(send el set-innerHTML! (list 'span '((class "blink")) (tr 'paused))))
|
||||
((eq? st 'starting)
|
||||
(set-play-button "buttons/pause.svg")
|
||||
(send el
|
||||
set-innerHTML!
|
||||
(list 'span (tr 'starting))))
|
||||
((eq? st 'quit)
|
||||
(void))
|
||||
(else
|
||||
@@ -377,7 +541,113 @@
|
||||
)
|
||||
|
||||
(define player #f)
|
||||
(define active-player-id 'm-play-local)
|
||||
(define dlna-renderers '())
|
||||
(define renderer-preferences
|
||||
(new renderer-preferences%
|
||||
[settings settings]))
|
||||
(define page-ready #f)
|
||||
|
||||
(define/private (get-media-library library-cfg)
|
||||
(send library-factory
|
||||
get-library
|
||||
(send library-cfg get-id)
|
||||
(send library-cfg get-kind)
|
||||
(send library-cfg get-kind-version)))
|
||||
|
||||
(define/private (update-library-title! [library-cfg #f])
|
||||
(send this
|
||||
set-title!
|
||||
(if library-cfg
|
||||
(format "~a - ~a"
|
||||
application-title
|
||||
(send library-cfg get-name))
|
||||
application-title)))
|
||||
|
||||
(define/private (use-library! library-cfg)
|
||||
(let ((current-library
|
||||
(send libraries-config current-library)))
|
||||
(unless (and current-library
|
||||
(eq? (send current-library get-id)
|
||||
(send library-cfg get-id))
|
||||
(send library-cfg is-current?))
|
||||
(when current-library
|
||||
(send current-library set-current! #f))
|
||||
(send library-cfg set-current! #t))
|
||||
(set! library-browser
|
||||
(new library-browser%
|
||||
[media-library
|
||||
(get-media-library library-cfg)]))
|
||||
(update-library-title! library-cfg)))
|
||||
|
||||
(define/private (initialize-library-browser!)
|
||||
(let ((current-library
|
||||
(send libraries-config current-library)))
|
||||
(if current-library
|
||||
(use-library! current-library)
|
||||
(begin
|
||||
(set! library-browser #f)
|
||||
(update-library-title!)))))
|
||||
|
||||
(define/public (select-library-by-index library-idx)
|
||||
(let ((library-cfg
|
||||
(list-ref (send libraries-config libraries)
|
||||
library-idx)))
|
||||
(use-library! library-cfg)
|
||||
(send this update-main-menu)
|
||||
(send this update-library)))
|
||||
|
||||
(define/public (update-main-menu)
|
||||
(let* ((libraries (send libraries-config libraries))
|
||||
(current-library (send libraries-config current-library))
|
||||
(current-library-id
|
||||
(and current-library
|
||||
(send current-library get-id)))
|
||||
(connections '())
|
||||
(menu
|
||||
(player-menu
|
||||
dlna-renderers
|
||||
libraries
|
||||
active-player-id
|
||||
current-library-id
|
||||
(lambda (id idx)
|
||||
(set! connections
|
||||
(cons
|
||||
(lambda ()
|
||||
(send this disconnect-menu! id)
|
||||
(send this connect-menu!
|
||||
id
|
||||
(lambda ()
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (e)
|
||||
(warn-rktplayer
|
||||
"Could not select media renderer: ~a; context: ~s"
|
||||
(exn-message e)
|
||||
(continuation-mark-set->context
|
||||
(exn-continuation-marks e)))
|
||||
(send this
|
||||
message!
|
||||
(exn-message e)
|
||||
#:clear #t
|
||||
#:error #t))))
|
||||
(send this play-to-dlna idx)))))
|
||||
connections)))
|
||||
(lambda (id idx)
|
||||
(set! connections
|
||||
(cons
|
||||
(lambda ()
|
||||
(send this disconnect-menu! id)
|
||||
(send this connect-menu!
|
||||
id
|
||||
(lambda ()
|
||||
(send this select-library-by-index idx))))
|
||||
connections))))))
|
||||
(send this set-menu! menu)
|
||||
(for-each (lambda (connect)
|
||||
(connect))
|
||||
connections)
|
||||
(void)))
|
||||
|
||||
(define/public (play-local)
|
||||
(unless (eq? player #f)
|
||||
@@ -391,13 +661,18 @@
|
||||
[audio-info-cb update-audio-info]
|
||||
[settings settings]
|
||||
))
|
||||
(set! active-player-id 'm-play-local)
|
||||
(unless (eq? playlist #f)
|
||||
(send player playlist! playlist))
|
||||
)
|
||||
|
||||
(define/public (play-to-dlna renderer-idx)
|
||||
(let* ((entry (list-ref dlna-renderers renderer-idx))
|
||||
(renderer (cadr entry)))
|
||||
(let ((renderer
|
||||
(list-ref dlna-renderers renderer-idx)))
|
||||
(info-rktplayer
|
||||
"Selecting media renderer index=~a name=~a"
|
||||
renderer-idx
|
||||
(send renderer get-name))
|
||||
(unless (eq? player #f)
|
||||
(send player stop)
|
||||
(send player quit))
|
||||
@@ -407,11 +682,35 @@
|
||||
[time-updater update-time]
|
||||
[track-nr-updater update-track-nr]
|
||||
[state-updater update-state]
|
||||
[error-updater
|
||||
(lambda (kind detail)
|
||||
(send this
|
||||
message!
|
||||
(case kind
|
||||
((renderer-unreachable)
|
||||
(format
|
||||
(tr 'renderer-unreachable)
|
||||
detail))
|
||||
((renderer-command-failed)
|
||||
(format
|
||||
(tr 'renderer-command-failed)
|
||||
detail))
|
||||
(else
|
||||
(format
|
||||
(tr 'playback-failed)
|
||||
detail)))
|
||||
#:clear #t
|
||||
#:error #t))]
|
||||
[repeat-updater update-repeat]
|
||||
[audio-info-cb update-audio-info]
|
||||
[settings settings]))
|
||||
(set! active-player-id
|
||||
(string->symbol
|
||||
(format "m-renderer-~a" renderer-idx)))
|
||||
(unless (eq? playlist #f)
|
||||
(send player playlist! playlist))))
|
||||
(send player playlist! playlist))
|
||||
(when page-ready
|
||||
(send this update-main-menu))))
|
||||
|
||||
(define/public (dlna-query-busy)
|
||||
(send this message! (tr 'dlna-query-busy) #:clear #t))
|
||||
@@ -419,21 +718,13 @@
|
||||
(define/public (set-dlna-renderers! renderers)
|
||||
(set! dlna-renderers renderers)
|
||||
(send this message! (format (tr 'dlna-renderers-count) (length renderers)) #:clear #t)
|
||||
(let ((connector-list '()))
|
||||
(send this set-menu! (player-menu renderers (λ (id idx)
|
||||
(set! connector-list
|
||||
(cons
|
||||
(λ ()
|
||||
(send this connect-menu! id
|
||||
(λ ()
|
||||
(displayln (format "dlna playback: ~a" idx))
|
||||
(send this play-to-dlna idx))))
|
||||
connector-list)))))
|
||||
(for-each (λ (c) (c)) connector-list)
|
||||
#t))
|
||||
(send this update-main-menu)
|
||||
#t)
|
||||
|
||||
(define/public (check-dlna)
|
||||
(check-dlna-players this))
|
||||
(check-dlna-players
|
||||
this
|
||||
renderer-preferences))
|
||||
|
||||
(define inner-html-handlers (make-hash))
|
||||
|
||||
@@ -467,17 +758,32 @@
|
||||
(dbg-rktplayer "el-volume: ~a" (send el-volume get))
|
||||
(let ((volume-reactor (webview-delayed-reactor 1.0
|
||||
(λ (volume-range)
|
||||
(let ((percentage (* volume-range volume-range)))
|
||||
(send this set-volume! percentage)))
|
||||
(send this set-volume! volume-range))
|
||||
#:update (λ (val)
|
||||
(let ((p (* val val)))
|
||||
(send el-vol-perc set-innerHTML! (sprintf "%d%" p))
|
||||
)))))
|
||||
(send el-vol-perc
|
||||
set-innerHTML!
|
||||
(sprintf "%d%" val))))))
|
||||
(send el-volume on-change! volume-reactor))
|
||||
|
||||
|
||||
(set! el-library (send this element 'library))
|
||||
(set! el-playlist (send this element 'tracks))
|
||||
(send this
|
||||
bind!
|
||||
'album-art
|
||||
'contextmenu
|
||||
(lambda (element event data)
|
||||
(popup-current-booklet data)))
|
||||
(set! playlist-gui
|
||||
(new playlist-gui%
|
||||
[window this]
|
||||
[element el-playlist]
|
||||
[play-track-callback
|
||||
(lambda (track-idx)
|
||||
(send this play-track track-idx))]
|
||||
[playlist-changed-callback
|
||||
(lambda ()
|
||||
(send this update-playlist))]))
|
||||
|
||||
(set! el-at (send this element 'time))
|
||||
(set! el-length (send this element 'totaltime))
|
||||
@@ -486,13 +792,19 @@
|
||||
(set! el-bits (send this element 'bits))
|
||||
(set! el-channels (send this element 'channels))
|
||||
(set! el-format (send this element 'format))
|
||||
(set! el-source (send this element 'source))
|
||||
|
||||
(send this set-menu! (player-menu '() (λ (id idx) #t)))
|
||||
(set! page-ready #t)
|
||||
(send this update-main-menu)
|
||||
(send this connect-menu! 'm-quit (λ () (send this quit)))
|
||||
(send this connect-menu! 'm-select-library-dir (λ () (send this select-library)))
|
||||
(send this connect-menu! 'm-settings (λ () (send this settings-dlg)))
|
||||
(send this connect-menu! 'm-add-tab (λ () (send this add-tab)))
|
||||
(send this connect-menu! 'm-play-local (λ () (send this play-local)))
|
||||
(send this connect-menu!
|
||||
'm-play-local
|
||||
(λ ()
|
||||
(send this play-local)
|
||||
(send this update-main-menu)))
|
||||
(send this connect-menu! 'm-check-dlna (λ () (send this check-dlna)))
|
||||
|
||||
(dbg-rktplayer "page-loaded, playlist = ~a" playlist)
|
||||
@@ -505,65 +817,11 @@
|
||||
(update-state 'stopped))
|
||||
)
|
||||
|
||||
(define el-dragged #f)
|
||||
|
||||
(define/public (update-playlist)
|
||||
(let* ((html (send playlist to-html))
|
||||
(result (send el-playlist set-innerHTML! html))
|
||||
)
|
||||
(dbg-rktplayer "result: ~a" result)
|
||||
(send this set-attr! "table.tracks tr" '(draggable "true"))
|
||||
(send this bind! "table.tracks tr" 'click
|
||||
(λ (el evt data)
|
||||
(let* ((track-id (send el attr/symbol 'id))
|
||||
(idx (send playlist index track-id))
|
||||
)
|
||||
(send this play-track idx)
|
||||
)
|
||||
)
|
||||
)
|
||||
(send this bind! "table.tracks tr" 'contextmenu
|
||||
(λ (el evt data)
|
||||
(let ((mnu (wv-menu 'track-menu
|
||||
(wv-menu-item 'm-drop-track "Drop track"
|
||||
#:callback (λ ()
|
||||
(send playlist drop-id (send el id))
|
||||
(update-playlist))
|
||||
)
|
||||
)
|
||||
)
|
||||
(clientX (hash-ref data 'clientX 60))
|
||||
(clientY (hash-ref data 'clientY 60))
|
||||
)
|
||||
(send this popup-menu! mnu clientX clientY))))
|
||||
(let ((from-idx #f)
|
||||
(to-idx #f))
|
||||
(send this bind! "table.tracks tr" 'dragstart
|
||||
(λ (el evt data)
|
||||
(set! el-dragged el)
|
||||
(dbg-rktplayer "Dragging element ~a" (send el id))
|
||||
(set! from-idx (send playlist index (send el id)))
|
||||
)
|
||||
#t)
|
||||
(send this bind! "table.tracks tr" 'dragover
|
||||
(λ (el evt data)
|
||||
#t)
|
||||
)
|
||||
(send this bind! "table.tracks tr" 'drop
|
||||
(λ (el evt data)
|
||||
(dbg-rktplayer "Element dropped on ~a" (send el id))
|
||||
(set! to-idx (send playlist index (send el id)))
|
||||
(when (and (integer? from-idx) (integer? to-idx)
|
||||
(not (= from-idx to-idx)))
|
||||
(send playlist move-track from-idx to-idx)
|
||||
(update-playlist)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(update-track-nr current-track-nr)
|
||||
)
|
||||
(send playlist-gui
|
||||
update!
|
||||
playlist
|
||||
current-track-nr)
|
||||
(send this update-volume)
|
||||
)
|
||||
|
||||
@@ -578,83 +836,169 @@
|
||||
"}")
|
||||
id)))
|
||||
|
||||
(define/public (update-library)
|
||||
(when (eq? current-music-path #f)
|
||||
(set! current-music-path music-library))
|
||||
(let* ((nr 0)
|
||||
(l (filter (λ (r) (music-lib-relevant? (cadr r)))
|
||||
(map (λ (e)
|
||||
(set! nr (+ nr 1))
|
||||
(list (format "row-~a" nr) (build-path current-music-path e) (format "path-~a" nr)))
|
||||
(if (directory-exists? current-music-path)
|
||||
(directory-list current-music-path)
|
||||
'())))))
|
||||
(unless (path-equal? current-music-path music-library)
|
||||
(set! l (cons (list "lib-up" "↰" "lib-up") l))
|
||||
)
|
||||
(let ((html (mktable l 'music-library library-formatter)))
|
||||
(define/private (render-library! browser items can-go-up?)
|
||||
(hash-clear! library-items)
|
||||
(let ((rows '()))
|
||||
(when browser
|
||||
(let ((item-nr 0))
|
||||
(set! rows
|
||||
(map
|
||||
(lambda (item)
|
||||
(let ((item-id (format "media-item-~a" item-nr)))
|
||||
(set! item-nr (+ item-nr 1))
|
||||
(hash-set! library-items item-id item)
|
||||
(list (format "row-~a" item-nr)
|
||||
item-id
|
||||
(send item get-title))))
|
||||
items)))
|
||||
(when can-go-up?
|
||||
(set! rows
|
||||
(cons (list "lib-up" "lib-up" "↰")
|
||||
rows))))
|
||||
(let ((html (mktable rows 'music-library media-item-formatter)))
|
||||
(let ((result (send el-library set-innerHTML! html)))
|
||||
(dbg-rktplayer "set-innerHTML!: ~a" result)
|
||||
(send this scroll-top 'library)
|
||||
(dbg-rktplayer "Binding...")
|
||||
(send this bind! "td.library-entry" 'click
|
||||
(λ (el evt data)
|
||||
(dbg-rktplayer "~a ~a" evt data)
|
||||
(dbg-rktplayer "id:~a, file:~a" (send el attr 'id) (send el attr 'file))
|
||||
(let ((path (send el attr 'file)))
|
||||
(unless (eq? path #f)
|
||||
(send this path-choosen path)))))
|
||||
(lambda (el evt data)
|
||||
(let ((item-id (send el attr 'item-id)))
|
||||
(cond
|
||||
((equal? item-id "lib-up")
|
||||
(send browser go-up!)
|
||||
(send this update-library))
|
||||
((hash-has-key? library-items item-id)
|
||||
(let ((container
|
||||
(send (hash-ref library-items item-id)
|
||||
get-container)))
|
||||
(when container
|
||||
(send browser open-container! container)
|
||||
(send this update-library))))))))
|
||||
(send this bind! "td.library-entry" 'contextmenu
|
||||
(λ (el evt data)
|
||||
(dbg-rktplayer "~a ~a" evt data)
|
||||
(let ((path (send el attr 'file)))
|
||||
(unless (eq? path #f)
|
||||
(send this context-for-path data path)))
|
||||
))
|
||||
(dbg-rktplayer "Done...")
|
||||
(lambda (el evt data)
|
||||
(let ((item-id (send el attr 'item-id)))
|
||||
(when (hash-has-key? library-items item-id)
|
||||
(send this
|
||||
context-for-media-item
|
||||
data
|
||||
(hash-ref library-items item-id))))))))))
|
||||
|
||||
))
|
||||
)
|
||||
)
|
||||
(define/private (library-update-current? request browser)
|
||||
(and (= request library-update-request)
|
||||
(eq? browser library-browser)
|
||||
page-ready
|
||||
(not closed)))
|
||||
|
||||
(define/public (path-choosen path)
|
||||
(let ((path-part (if (equal? path "↰") ".." (format "~a" path))))
|
||||
(let ((npath (if (string=? path-part "..")
|
||||
(build-path current-music-path path-part)
|
||||
path)))
|
||||
(when (directory-exists? npath)
|
||||
(set! current-music-path (normalize-path npath))
|
||||
(send this update-library)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(define/public (update-library)
|
||||
(set! library-update-request (+ library-update-request 1))
|
||||
(let ((request library-update-request)
|
||||
(browser library-browser))
|
||||
(hash-clear! library-items)
|
||||
(if browser
|
||||
(begin
|
||||
(send el-library
|
||||
set-innerHTML!
|
||||
(xexpr->string
|
||||
(list 'div
|
||||
'((class "library-loading"))
|
||||
(tr 'searching))))
|
||||
(thread
|
||||
(lambda ()
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (exception)
|
||||
(when (library-update-current? request browser)
|
||||
(warn-rktplayer
|
||||
"Could not browse music library: ~a"
|
||||
(exn-message exception))
|
||||
(send this
|
||||
message!
|
||||
(format
|
||||
(tr 'library-browse-failed)
|
||||
(exn-message exception))
|
||||
#:clear #t
|
||||
#:error #t)
|
||||
(render-library! browser '() #f)))))
|
||||
(let ((items (send browser get-items))
|
||||
(can-go-up? (send browser can-go-up?)))
|
||||
(when (library-update-current? request browser)
|
||||
(render-library! browser items can-go-up?)))))))
|
||||
(render-library! #f '() #f)))
|
||||
(void))
|
||||
|
||||
(define/public (context-for-path evt path)
|
||||
(let ((items (list
|
||||
(wv-menu-item 'm-play-this (tr 'play-this) #:callback (λ () (send this play-path path))))))
|
||||
(when (file-exists? path)
|
||||
(set! items (append items
|
||||
(list
|
||||
(wv-menu-item 'm-add-this (tr 'add-this) #:callback (λ () (send this add-path path)))))))
|
||||
(when (file-exists? (build-path path "booklet.pdf"))
|
||||
(set! items (append items
|
||||
(list
|
||||
(wv-menu-item 'm-booklet (tr 'open-booklet) #:callback (λ () (send this open-booklet path))) ;; todo check if pdf file exists
|
||||
))))
|
||||
(define/private (media-item-containing-folder item)
|
||||
(let ((track (send item get-track)))
|
||||
(if track
|
||||
(let* ((resource (send track get-resource))
|
||||
(file
|
||||
(and resource
|
||||
(is-a? resource
|
||||
media-resource-file%)
|
||||
(send resource get-file))))
|
||||
(and file
|
||||
(path-only file)))
|
||||
(let* ((container-id (send item get-id))
|
||||
(media-library
|
||||
(send library-browser get-media-library)))
|
||||
(and (eq? (send media-library get-kind)
|
||||
'filesystem)
|
||||
(send media-library
|
||||
resolve-path
|
||||
(cdr container-id)))))))
|
||||
|
||||
(set! items (append items
|
||||
(list
|
||||
(wv-menu-item 'm-folder (tr 'open-containing-folder) #:callback (λ () (send this open-folder path)))
|
||||
)))
|
||||
(let* ((mnu (wv-menu 'library-popup items))
|
||||
(clientX (hash-ref evt 'clientX 60))
|
||||
(clientY (hash-ref evt 'clientY 60))
|
||||
)
|
||||
(send this popup-menu! mnu clientX clientY)
|
||||
)
|
||||
)
|
||||
)
|
||||
(define/public (context-for-media-item evt item)
|
||||
(let* ((track (send item get-track))
|
||||
(containing-folder
|
||||
(media-item-containing-folder item))
|
||||
(items
|
||||
(list
|
||||
(wv-menu-item
|
||||
'm-play-this
|
||||
(tr 'play-this)
|
||||
#:callback
|
||||
(lambda ()
|
||||
(send this play-media-item item)))
|
||||
(wv-menu-item
|
||||
'm-add-this
|
||||
(tr 'add-this)
|
||||
#:callback
|
||||
(lambda ()
|
||||
(send this add-media-item item))))))
|
||||
(when (and track
|
||||
(send track has-booklet?))
|
||||
(set! items
|
||||
(append
|
||||
items
|
||||
(list
|
||||
(wv-menu-item
|
||||
'm-booklet
|
||||
(tr 'open-booklet)
|
||||
#:callback
|
||||
(lambda ()
|
||||
(send this
|
||||
open-booklet
|
||||
(send track booklet-file)
|
||||
#t)))))))
|
||||
(when containing-folder
|
||||
(set! items
|
||||
(append
|
||||
items
|
||||
(list
|
||||
(wv-menu-item
|
||||
'm-folder
|
||||
(tr 'open-containing-folder)
|
||||
#:callback
|
||||
(lambda ()
|
||||
(send this
|
||||
open-folder
|
||||
containing-folder)))))))
|
||||
(let ((menu (wv-menu 'library-popup items))
|
||||
(client-x (hash-ref evt 'clientX 60))
|
||||
(client-y (hash-ref evt 'clientY 60)))
|
||||
(send this
|
||||
popup-menu!
|
||||
menu
|
||||
client-x
|
||||
client-y))))
|
||||
|
||||
(define play-remote #f)
|
||||
(define/public (toggle-remote)
|
||||
@@ -671,22 +1015,18 @@
|
||||
(info-rktplayer "Playing remote: ~a" play-remote)
|
||||
)
|
||||
|
||||
(define/public (play-path path)
|
||||
(dbg-rktplayer "Playing ~a" path)
|
||||
(let ((pl (new playlist% [start-map path] [settings (send settings clone 'playlists)] [id current-tab])))
|
||||
(set! current-track-nr #f)
|
||||
(send pl read-tracks)
|
||||
(set! playlist pl)
|
||||
(send this update-playlist)
|
||||
(send player play pl)
|
||||
(dbg-rktplayer "number of tracks: ~a" (send playlist length))
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (add-path path)
|
||||
(send playlist add-track path)
|
||||
(define/public (play-media-item item)
|
||||
(set! current-track-nr #f)
|
||||
(send playlist replace-with-media-item! item)
|
||||
(send this update-playlist)
|
||||
)
|
||||
(send player play playlist)
|
||||
(dbg-rktplayer
|
||||
"number of tracks: ~a"
|
||||
(send playlist length)))
|
||||
|
||||
(define/public (add-media-item item)
|
||||
(send playlist add-media-item item)
|
||||
(send this update-playlist))
|
||||
|
||||
(define/public (open-booklet path . is-file*)
|
||||
(let* ((is-file (if (null? is-file*) #f (eq? (car is-file*) #t)))
|
||||
@@ -752,7 +1092,7 @@
|
||||
(begin
|
||||
(send volume-meter display 'block)
|
||||
(send el-volume set!
|
||||
(sqrt (send player get-volume)))
|
||||
(send player get-volume))
|
||||
(send el-vol-perc set-innerHTML!
|
||||
(sprintf "%d%" (send player get-volume))))
|
||||
)
|
||||
@@ -771,18 +1111,37 @@
|
||||
|
||||
(define/override (quit)
|
||||
(dbg-rktplayer "Quitting")
|
||||
(send player quit)
|
||||
(set! closed #t)
|
||||
(when playlist
|
||||
(send playlist stop-cache!))
|
||||
(send player quit)
|
||||
(send this close)
|
||||
(dbg-rktplayer "Calling super -> quit")
|
||||
(super quit)
|
||||
)
|
||||
|
||||
(define/public (settings-dlg)
|
||||
(let ((dlg (new settings% [settings (send settings clone 'settings-dlg)]
|
||||
[parent this])))
|
||||
(let ((dlg (new settings%
|
||||
[settings (send settings clone 'settings-dlg)]
|
||||
[parent this]
|
||||
[renderers dlna-renderers]
|
||||
[libraries-changed-callback
|
||||
(lambda ()
|
||||
(initialize-library-browser!)
|
||||
(when page-ready
|
||||
(send this update-main-menu)
|
||||
(send this update-library)))]
|
||||
[cache-cleared-callback
|
||||
(lambda ()
|
||||
(when playlist
|
||||
(send playlist reset-cache!)
|
||||
(when page-ready
|
||||
(send this update-playlist))))])))
|
||||
(send dlg show)))
|
||||
|
||||
(define/public (select-library)
|
||||
(send this settings-dlg))
|
||||
|
||||
|
||||
(define/public (show-hide)
|
||||
(let ((st (send this window-state)))
|
||||
@@ -808,11 +1167,16 @@
|
||||
(begin
|
||||
(dbg-rktplayer "Initializing local player")
|
||||
(play-local)
|
||||
(initialize-library-browser!)
|
||||
(dbg-rktplayer "Initalizing gui")
|
||||
(dbg-rktplayer "ICON: ~a" (get-field icon this))
|
||||
(let ((lang (send settings get 'lang 'en)))
|
||||
(dbg-rktplayer "RktPlayer started, current language: ~a" lang))
|
||||
(set! playlist (new playlist% [settings (send settings clone 'playlists)]))
|
||||
(set! playlist
|
||||
(new playlist%
|
||||
[settings
|
||||
(send settings clone 'playlists)]
|
||||
[cache-updated cache-updated]))
|
||||
(send player set-list! playlist)
|
||||
(dbg-rktplayer "playlist = ~a" playlist)
|
||||
|
||||
|
Before Width: | Height: | Size: 893 B After Width: | Height: | Size: 894 B |
|
Before Width: | Height: | Size: 849 B After Width: | Height: | Size: 846 B |
|
Before Width: | Height: | Size: 1.8 KiB After Width: | Height: | Size: 1.8 KiB |
|
Before Width: | Height: | Size: 903 B After Width: | Height: | Size: 904 B |
|
Before Width: | Height: | Size: 2.1 KiB After Width: | Height: | Size: 2.1 KiB |
|
Before Width: | Height: | Size: 1.5 KiB After Width: | Height: | Size: 1.5 KiB |
|
Before Width: | Height: | Size: 1.2 KiB After Width: | Height: | Size: 1.2 KiB |
|
Before Width: | Height: | Size: 1.7 KiB After Width: | Height: | Size: 1.7 KiB |
|
Before Width: | Height: | Size: 1.3 KiB After Width: | Height: | Size: 1.3 KiB |
|
Before Width: | Height: | Size: 1.3 KiB After Width: | Height: | Size: 1.3 KiB |
|
Before Width: | Height: | Size: 1.2 KiB After Width: | Height: | Size: 1.2 KiB |
|
Before Width: | Height: | Size: 3.9 KiB After Width: | Height: | Size: 3.9 KiB |
|
Before Width: | Height: | Size: 92 KiB After Width: | Height: | Size: 92 KiB |
@@ -0,0 +1,56 @@
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<link rel="stylesheet" href="styles.css" />
|
||||
<meta charset="UTF-8" />
|
||||
<title>RktPlayer - A music player - library entry</title>
|
||||
</head>
|
||||
<body>
|
||||
<div class="pane">
|
||||
<div class="keyval">
|
||||
<label for="selected-library-kind" id="lbl-kind">Kind:</label>
|
||||
<select id="selected-library-kind"></select>
|
||||
</div>
|
||||
<hr />
|
||||
<div class="keyval">
|
||||
<label for="name" id="lbl-name">Name:</label>
|
||||
<input type="text" id="name" />
|
||||
</div>
|
||||
<div id="filesystem-fields">
|
||||
<div class="keyval">
|
||||
<label for="local-path" id="lbl-local-path">Local path:</label>
|
||||
<div class="file-box">
|
||||
<input id="local-path" type="text" />
|
||||
<button id="browse">Browse</button>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
<div id="media-server-fields" style="display: none">
|
||||
<div class="keyval">
|
||||
<label for="selected-media-server" id="lbl-media-server">Media server:</label>
|
||||
<div class="file-box">
|
||||
<select id="selected-media-server"></select>
|
||||
<button id="refresh-media-servers">Refresh</button>
|
||||
</div>
|
||||
</div>
|
||||
<div class="keyval">
|
||||
<label for="selected-media-server-container" id="lbl-media-server-root">Start point:</label>
|
||||
<div class="file-box">
|
||||
<span id="media-server-root"></span>
|
||||
<button id="media-server-root-up">Up</button>
|
||||
<select id="selected-media-server-container"></select>
|
||||
</div>
|
||||
</div>
|
||||
<div class="keyval">
|
||||
<label for="media-server-item-limit" id="lbl-media-server-item-limit">Maximum items:</label>
|
||||
<input id="media-server-item-limit" type="number" min="1" />
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
<div class="button-box">
|
||||
<button id="ok">OK</button>
|
||||
<button id="cancel">Cancel</button>
|
||||
<button id="dev">devtools</button>
|
||||
</div>
|
||||
</body>
|
||||
</html>
|
||||
@@ -22,7 +22,7 @@
|
||||
<img id="volume-img" src="buttons/volume-high.svg" />
|
||||
<div id="volume-meter" class="volume-meter">
|
||||
<div class="status"><span class="info" id="volume-perc"></span></div>
|
||||
<input type="range" min="0" max="13" value="10" class="v-slider" id="volume-range" step="0.1" />
|
||||
<input type="range" min="0" max="100" value="50" class="v-slider" id="volume-range" step="1" />
|
||||
</div>
|
||||
</button>
|
||||
</div>
|
||||
@@ -53,6 +53,7 @@
|
||||
<span class="info" id="rate"></span>
|
||||
<span class="info" id="channels"></span>
|
||||
<span class="info" id="format"></span>
|
||||
<span class="info" id="source"></span>
|
||||
<span class="info" id="paused"></span>
|
||||
<span class="info" id="message"></span>
|
||||
<div class="right">
|
||||
|
Before Width: | Height: | Size: 60 KiB After Width: | Height: | Size: 60 KiB |
|
Before Width: | Height: | Size: 4.2 KiB After Width: | Height: | Size: 4.2 KiB |
@@ -16,7 +16,7 @@
|
||||
<hr />
|
||||
<table class="libraries">
|
||||
<thead id="lib-head">
|
||||
<tr><th id="lbl-name"></th><th id="lbl-local-path"></th><th id="lbl-host"></th><th id="lbl-prefixes"></th></tr>
|
||||
<tr><th id="lbl-name"></th><th id="lbl-kind"></th><th id="lbl-local-path"></th><th id="lbl-host"></th></tr>
|
||||
</thead>
|
||||
<tbody id="lib-body">
|
||||
</tbody>
|
||||
@@ -26,6 +26,22 @@
|
||||
<button id="edit">Edit Library</button>
|
||||
<button id="remove">Remove Library</button>
|
||||
</div>
|
||||
<hr />
|
||||
<div class="button-box">
|
||||
<button id="clear-cache">Clear downloaded tracks</button>
|
||||
</div>
|
||||
<hr />
|
||||
<label id="lbl-renderers">Audio Players</label>
|
||||
<table class="renderers">
|
||||
<thead>
|
||||
<tr>
|
||||
<th id="lbl-renderer-name">Name</th>
|
||||
<th id="lbl-volume-curve">Logarithmic volume</th>
|
||||
</tr>
|
||||
</thead>
|
||||
<tbody id="renderer-body">
|
||||
</tbody>
|
||||
</table>
|
||||
</div>
|
||||
<div class="button-box">
|
||||
<button id="ok">OK</button>
|
||||
@@ -273,12 +273,14 @@ table.tracks td.title, table.tracks td.album {
|
||||
}
|
||||
|
||||
table.tracks tr, table.tracks td,
|
||||
table.libraries tr, table.libraries td {
|
||||
table.libraries tr, table.libraries td,
|
||||
table.renderers tr, table.renderers td {
|
||||
cursor: default;
|
||||
user-select: none;
|
||||
}
|
||||
|
||||
table.tracks tr:hover, table.libraries tbody tr:hover {
|
||||
table.tracks tr:hover, table.libraries tbody tr:hover,
|
||||
table.renderers tbody tr:hover {
|
||||
background: #e0e0e0;
|
||||
color: black;
|
||||
transition: all 0.5s ease-in;
|
||||
@@ -296,6 +298,18 @@ table.libraries tbody tr.current {
|
||||
color: #f3961e;
|
||||
}
|
||||
|
||||
table.tracks tr.unavailable {
|
||||
color: #777777;
|
||||
}
|
||||
|
||||
table.tracks tr.unavailable:hover {
|
||||
color: #777777;
|
||||
}
|
||||
|
||||
table.tracks tr.failed {
|
||||
color: #a06060;
|
||||
}
|
||||
|
||||
.album-art .content img {
|
||||
width: auto;
|
||||
height: calc(100% - 20px);
|
||||
@@ -388,6 +402,11 @@ input.v-slider {
|
||||
animation: blink 3s infinite both;
|
||||
}
|
||||
|
||||
.error {
|
||||
color: #d60000;
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
@keyframes blink {
|
||||
0%,
|
||||
50%,
|
||||
@@ -1,41 +0,0 @@
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<link rel="stylesheet" href="styles.css" />
|
||||
<meta charset="UTF-8" />
|
||||
<title>RktPlayer - A music player - library entry</title>
|
||||
</head>
|
||||
<body>
|
||||
<div class="pane">
|
||||
<div class="keyval">
|
||||
<label for="kind" id="lbl-kind">Action:</label>
|
||||
<span id="kind">Action</span>
|
||||
</div>
|
||||
<hr />
|
||||
<div class="keyval">
|
||||
<label for="name" id="lbl-name">Name:</label>
|
||||
<input type="text" id="name" />
|
||||
</div>
|
||||
<div class="keyval">
|
||||
<label for="local-path" id="lbl-local-path">Local path:</label>
|
||||
<div class="file-box">
|
||||
<input id="local-path" type="text" />
|
||||
<button id="browse">Browse</button>
|
||||
</div>
|
||||
</div>
|
||||
<div class="keyval">
|
||||
<label for="host" id="lbl-host">Host:</label>
|
||||
<input type="text" id="host" />
|
||||
</div>
|
||||
<div class="keyval">
|
||||
<label for="prefixes" id="lbl-prefixes">Prefixes:</label>
|
||||
<textarea type="text" id="prefixes"></textarea>
|
||||
</div>
|
||||
</div>
|
||||
<div class="button-box">
|
||||
<button id="ok">OK</button>
|
||||
<button id="cancel">Cancel</button>
|
||||
<button id="dev">devtools</button>
|
||||
</div>
|
||||
</body>
|
||||
</html>
|
||||
@@ -0,0 +1,800 @@
|
||||
#lang racket
|
||||
|
||||
(require racket-webview
|
||||
racket/runtime-path
|
||||
racket/gui
|
||||
racket-sprintf
|
||||
open-app
|
||||
xml
|
||||
(prefix-in upnp: racket-upnp)
|
||||
"../misc/utils.rkt"
|
||||
"translate.rkt"
|
||||
"../play/playlist.rkt"
|
||||
"../play/base/player.rkt"
|
||||
"../library/libraries-config.rkt"
|
||||
"../library/library-factory.rkt"
|
||||
"../play/base/renderer.rkt"
|
||||
)
|
||||
|
||||
(provide
|
||||
(all-from-out racket-webview)
|
||||
settings%
|
||||
)
|
||||
|
||||
(define-runtime-path rkt-gui-dir "html")
|
||||
|
||||
(define library-dlg%
|
||||
(class wv-dialog%
|
||||
(init-field [kind 'filesystem] [result-cb (λ args #f)]
|
||||
[id (new-id)] [name ""] [local-path ""]
|
||||
[host ""] [item-limit 100]
|
||||
[kind-editable? #t])
|
||||
(inherit-field settings icon parent)
|
||||
|
||||
(super-new
|
||||
[html-path "library-dialog.html"]
|
||||
[title (tr 'settings-library)]
|
||||
[icon (build-path rkt-gui-dir "rktplayer.png")]
|
||||
[quit-on-close #f]
|
||||
)
|
||||
|
||||
(define initialized #f)
|
||||
(define btn-ok #f)
|
||||
(define btn-cancel #f)
|
||||
(define lbl-name #f)
|
||||
(define lbl-kind #f)
|
||||
(define lbl-local-path #f)
|
||||
(define btn-browse #f)
|
||||
(define lbl-media-server #f)
|
||||
(define lbl-media-server-root #f)
|
||||
(define lbl-media-server-item-limit #f)
|
||||
(define btn-refresh-media-servers #f)
|
||||
(define btn-media-server-root-up #f)
|
||||
(define div-filesystem-fields #f)
|
||||
(define div-media-server-fields #f)
|
||||
(define txt-media-server-root #f)
|
||||
(define sel-library-kind #f)
|
||||
(define sel-media-server #f)
|
||||
(define sel-media-server-container #f)
|
||||
(define inp-local-path #f)
|
||||
(define inp-name #f)
|
||||
(define inp-media-server-item-limit #f)
|
||||
(define media-servers '())
|
||||
(define media-server-containers '())
|
||||
(define media-server-root-id
|
||||
(if (and (eq? kind 'media-server)
|
||||
(not (string=? local-path "")))
|
||||
local-path
|
||||
"0"))
|
||||
(define media-server-root-path '())
|
||||
(define media-server-root-parents '())
|
||||
(define media-server-root-request 0)
|
||||
|
||||
(define/public (set-labels)
|
||||
(send btn-ok set-innerHTML! (tr 'ok))
|
||||
(send btn-cancel set-innerHTML! (tr 'cancel))
|
||||
(send lbl-name set-innerHTML! (tr 'name))
|
||||
(send lbl-kind set-innerHTML! (tr 'library-kind))
|
||||
(send lbl-local-path set-innerHTML! (tr 'local-path))
|
||||
(send lbl-media-server set-innerHTML! (tr 'media-servers))
|
||||
(send lbl-media-server-root
|
||||
set-innerHTML!
|
||||
(tr 'media-server-root))
|
||||
(send lbl-media-server-item-limit
|
||||
set-innerHTML!
|
||||
(tr 'media-server-item-limit))
|
||||
(send btn-browse set-innerHTML! (tr 'browse))
|
||||
(send btn-refresh-media-servers set-innerHTML! (tr 'refresh))
|
||||
(send btn-media-server-root-up set-innerHTML! (tr 'up))
|
||||
)
|
||||
|
||||
(define/private (media-server-label server)
|
||||
(format "~a (~a)"
|
||||
(upnp:media-server-name server)
|
||||
(upnp:media-server-address server)))
|
||||
|
||||
(define/private (update-media-servers!)
|
||||
(let* ((items
|
||||
(if (null? media-servers)
|
||||
(list
|
||||
(list -1
|
||||
(tr 'no-media-servers)))
|
||||
(for/list ((server
|
||||
(in-list media-servers))
|
||||
(idx (in-naturals)))
|
||||
(list idx
|
||||
(media-server-label server)))))
|
||||
(selected-idx
|
||||
(or
|
||||
(for/first ((server (in-list media-servers))
|
||||
(idx (in-naturals))
|
||||
#:when
|
||||
(member host
|
||||
(filter
|
||||
values
|
||||
(list
|
||||
(upnp:upnp-device-udn server)
|
||||
(upnp:media-server-name server)
|
||||
(upnp:media-server-address server)))))
|
||||
idx)
|
||||
(if (null? media-servers)
|
||||
-1
|
||||
0))))
|
||||
(send sel-media-server
|
||||
set-options!
|
||||
items
|
||||
selected-idx)))
|
||||
|
||||
(define/public (refresh-media-servers)
|
||||
(set! media-servers '())
|
||||
(update-media-servers!)
|
||||
(send btn-refresh-media-servers
|
||||
set-innerHTML!
|
||||
(tr 'searching))
|
||||
(void
|
||||
(thread
|
||||
(lambda ()
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (exception)
|
||||
(warn-rktplayer
|
||||
"Could not query UPnP media servers: ~a"
|
||||
(exn-message exception))
|
||||
(set! media-servers '())
|
||||
(update-media-servers!)
|
||||
(set! media-server-containers '())
|
||||
(update-media-server-root!)
|
||||
(send btn-refresh-media-servers
|
||||
set-innerHTML!
|
||||
(tr 'refresh)))))
|
||||
(set! media-servers
|
||||
(upnp:query-media-servers))
|
||||
(update-media-servers!)
|
||||
(load-media-server-root!)
|
||||
(send btn-refresh-media-servers
|
||||
set-innerHTML!
|
||||
(tr 'refresh)))))))
|
||||
|
||||
(define/private (selected-media-server)
|
||||
(let* ((idx
|
||||
(string->number
|
||||
(get sel-media-server))))
|
||||
(and idx
|
||||
(>= idx 0)
|
||||
(< idx (length media-servers))
|
||||
(list-ref media-servers idx))))
|
||||
|
||||
(define/private (current-library-kind)
|
||||
(string->symbol
|
||||
(get sel-library-kind)))
|
||||
|
||||
(define/private (update-library-kind!)
|
||||
(case (current-library-kind)
|
||||
((filesystem)
|
||||
(send div-filesystem-fields display 'block)
|
||||
(send div-media-server-fields display 'none))
|
||||
((media-server)
|
||||
(send div-filesystem-fields display 'none)
|
||||
(send div-media-server-fields display 'block))))
|
||||
|
||||
(define/private (media-server-root-label)
|
||||
(if (null? media-server-root-path)
|
||||
(if (string=? media-server-root-id "0")
|
||||
"/"
|
||||
(format "~a" media-server-root-id))
|
||||
(string-append
|
||||
"/"
|
||||
(string-join
|
||||
media-server-root-path
|
||||
" / "))))
|
||||
|
||||
(define/private (update-media-server-root!
|
||||
[status #f])
|
||||
(let ((items
|
||||
(cond
|
||||
(status
|
||||
(list
|
||||
(list -1 status)))
|
||||
((null? media-server-containers)
|
||||
(list
|
||||
(list -1
|
||||
(tr 'no-media-server-containers))))
|
||||
(else
|
||||
(cons
|
||||
(list -1
|
||||
(tr 'select-media-server-container))
|
||||
(for/list
|
||||
((container
|
||||
(in-list media-server-containers))
|
||||
(idx (in-naturals)))
|
||||
(list
|
||||
idx
|
||||
(upnp:media-entry-title
|
||||
container))))))))
|
||||
(send txt-media-server-root
|
||||
set-innerHTML!
|
||||
(media-server-root-label))
|
||||
(send sel-media-server-container
|
||||
set-options!
|
||||
items
|
||||
-1)))
|
||||
|
||||
(define/private (load-media-server-root!)
|
||||
(set! media-server-root-request
|
||||
(add1 media-server-root-request))
|
||||
(let ((request media-server-root-request)
|
||||
(server (selected-media-server))
|
||||
(container-id media-server-root-id))
|
||||
(set! media-server-containers '())
|
||||
(update-media-server-root!
|
||||
(tr 'searching))
|
||||
(if server
|
||||
(void
|
||||
(thread
|
||||
(lambda ()
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (exception)
|
||||
(warn-rktplayer
|
||||
"Could not browse UPnP media-server container ~a: ~a"
|
||||
container-id
|
||||
(exn-message exception))
|
||||
(when (= request
|
||||
media-server-root-request)
|
||||
(set! media-server-containers '())
|
||||
(update-media-server-root!)))))
|
||||
(let ((containers
|
||||
(filter
|
||||
(lambda (entry)
|
||||
(and
|
||||
(upnp:media-container? entry)
|
||||
(string?
|
||||
(upnp:media-entry-id entry))))
|
||||
(upnp:media-server-browse
|
||||
server
|
||||
container-id
|
||||
#:count
|
||||
(current-media-server-item-limit)))))
|
||||
(when (= request
|
||||
media-server-root-request)
|
||||
(set! media-server-containers
|
||||
containers)
|
||||
(update-media-server-root!)))))))
|
||||
(update-media-server-root!))))
|
||||
|
||||
(define/private (reset-media-server-root!)
|
||||
(set! media-server-root-id "0")
|
||||
(set! media-server-root-path '())
|
||||
(set! media-server-root-parents '())
|
||||
(load-media-server-root!))
|
||||
|
||||
(define/private (open-media-server-container!)
|
||||
(let ((idx
|
||||
(string->number
|
||||
(get sel-media-server-container))))
|
||||
(when (and idx
|
||||
(>= idx 0)
|
||||
(< idx
|
||||
(length media-server-containers)))
|
||||
(let ((container
|
||||
(list-ref media-server-containers
|
||||
idx)))
|
||||
(set! media-server-root-parents
|
||||
(cons
|
||||
(list media-server-root-id
|
||||
media-server-root-path)
|
||||
media-server-root-parents))
|
||||
(set! media-server-root-id
|
||||
(upnp:media-entry-id
|
||||
container))
|
||||
(set! media-server-root-path
|
||||
(append
|
||||
media-server-root-path
|
||||
(list
|
||||
(upnp:media-entry-title
|
||||
container))))
|
||||
(load-media-server-root!)))))
|
||||
|
||||
(define/private (media-server-root-up!)
|
||||
(cond
|
||||
((not
|
||||
(null? media-server-root-parents))
|
||||
(let ((parent
|
||||
(car media-server-root-parents)))
|
||||
(set! media-server-root-id
|
||||
(car parent))
|
||||
(set! media-server-root-path
|
||||
(cadr parent))
|
||||
(set! media-server-root-parents
|
||||
(cdr media-server-root-parents))
|
||||
(load-media-server-root!)))
|
||||
((not
|
||||
(string=? media-server-root-id "0"))
|
||||
(reset-media-server-root!))))
|
||||
|
||||
(define (get el)
|
||||
(let ((str (send el get)))
|
||||
(string-trim str)))
|
||||
|
||||
(define/private (current-media-server-item-limit)
|
||||
(let ((value
|
||||
(send inp-media-server-item-limit get)))
|
||||
(if (exact-positive-integer? value)
|
||||
value
|
||||
100)))
|
||||
|
||||
(define/public (select-library)
|
||||
(let* ((music-library (get inp-local-path))
|
||||
(dir (send this choose-dir
|
||||
(tr 'choose-lib-folder)
|
||||
music-library
|
||||
)))
|
||||
(displayln "Directory kiezen")
|
||||
(if (eq? dir 'showing)
|
||||
'done
|
||||
(unless (eq? dir #f)
|
||||
(send inp-local-path set! dir))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/override (page-loaded oke)
|
||||
(unless initialized
|
||||
(when oke
|
||||
(set! initialized #t)
|
||||
(set! btn-ok (send this element 'ok))
|
||||
(set! btn-cancel (send this element 'cancel))
|
||||
(set! lbl-name (send this element 'lbl-name))
|
||||
(set! lbl-kind (send this element 'lbl-kind))
|
||||
(set! lbl-local-path (send this element 'lbl-local-path))
|
||||
(set! lbl-media-server (send this element 'lbl-media-server))
|
||||
(set! lbl-media-server-root
|
||||
(send this element
|
||||
'lbl-media-server-root))
|
||||
(set! lbl-media-server-item-limit
|
||||
(send this element
|
||||
'lbl-media-server-item-limit))
|
||||
(set! div-filesystem-fields
|
||||
(send this element
|
||||
'filesystem-fields))
|
||||
(set! div-media-server-fields
|
||||
(send this element
|
||||
'media-server-fields))
|
||||
(set! txt-media-server-root
|
||||
(send this element
|
||||
'media-server-root))
|
||||
(set! sel-library-kind
|
||||
(send this element
|
||||
'selected-library-kind))
|
||||
(set! sel-media-server
|
||||
(send this element
|
||||
'selected-media-server))
|
||||
(set! sel-media-server-container
|
||||
(send this element
|
||||
'selected-media-server-container))
|
||||
(set! inp-name (send this element 'name))
|
||||
(set! inp-local-path (send this element 'local-path))
|
||||
(set! inp-media-server-item-limit
|
||||
(send this element
|
||||
'media-server-item-limit))
|
||||
(set! btn-browse (send this element 'browse))
|
||||
(set! btn-refresh-media-servers
|
||||
(send this element
|
||||
'refresh-media-servers))
|
||||
(set! btn-media-server-root-up
|
||||
(send this element
|
||||
'media-server-root-up))
|
||||
|
||||
(send inp-name set! name)
|
||||
(send inp-local-path set! local-path)
|
||||
(send inp-media-server-item-limit
|
||||
set!
|
||||
(format "~a" item-limit))
|
||||
(send sel-library-kind
|
||||
set-options!
|
||||
(list
|
||||
(list 'filesystem
|
||||
(tr 'filesystem))
|
||||
(list 'media-server
|
||||
(tr 'media-server)))
|
||||
kind)
|
||||
(unless kind-editable?
|
||||
(send sel-library-kind
|
||||
set-attr!
|
||||
'((disabled "disabled"))))
|
||||
|
||||
(send this set-labels)
|
||||
(update-library-kind!)
|
||||
(update-media-server-root!)
|
||||
|
||||
(send sel-library-kind
|
||||
on-change!
|
||||
(lambda (value)
|
||||
(update-library-kind!)))
|
||||
(send sel-media-server
|
||||
on-change!
|
||||
(lambda (value)
|
||||
(reset-media-server-root!)))
|
||||
(send sel-media-server-container
|
||||
on-change!
|
||||
(lambda (value)
|
||||
(open-media-server-container!)))
|
||||
(send this refresh-media-servers)
|
||||
|
||||
(send this bind! 'browse 'click (λ (el evt data)
|
||||
(send this select-library)))
|
||||
(send this bind!
|
||||
'refresh-media-servers
|
||||
'click
|
||||
(lambda (element event data)
|
||||
(send this refresh-media-servers)))
|
||||
(send this bind!
|
||||
'media-server-root-up
|
||||
'click
|
||||
(lambda (element event data)
|
||||
(media-server-root-up!)))
|
||||
|
||||
(send this bind! 'ok 'click (λ (el evt data)
|
||||
(let ((name (get inp-name))
|
||||
(library-kind
|
||||
(string->symbol
|
||||
(get sel-library-kind)))
|
||||
(local-path (get inp-local-path)))
|
||||
(case library-kind
|
||||
((filesystem)
|
||||
(result-cb
|
||||
id
|
||||
name
|
||||
library-kind
|
||||
local-path
|
||||
host
|
||||
(current-media-server-item-limit))
|
||||
(send this close))
|
||||
((media-server)
|
||||
(let ((server
|
||||
(selected-media-server)))
|
||||
(when server
|
||||
(result-cb
|
||||
id
|
||||
(if (string=? name "")
|
||||
(upnp:media-server-name
|
||||
server)
|
||||
name)
|
||||
library-kind
|
||||
media-server-root-id
|
||||
(or
|
||||
(upnp:upnp-device-udn
|
||||
server)
|
||||
(upnp:media-server-name
|
||||
server))
|
||||
(current-media-server-item-limit))
|
||||
(send this close))))))))
|
||||
(send this bind! 'cancel 'click (λ (el evt data) (send this close)))
|
||||
(send this bind! 'dev 'click (λ args (send this devtools)))
|
||||
)
|
||||
))
|
||||
)
|
||||
)
|
||||
|
||||
(define settings%
|
||||
(class wv-dialog%
|
||||
(init-field
|
||||
[log-file #f]
|
||||
[renderers '()]
|
||||
[libraries-changed-callback (lambda () (void))]
|
||||
[cache-cleared-callback (lambda () (void))])
|
||||
(inherit-field settings icon parent)
|
||||
|
||||
(super-new
|
||||
[html-path "settings.html"]
|
||||
[title (tr 'settings-title)]
|
||||
[icon (build-path rkt-gui-dir "rktplayer.png")]
|
||||
[quit-on-close #f]
|
||||
)
|
||||
|
||||
(define initialized #f)
|
||||
(define btn-ok #f)
|
||||
(define btn-cancel #f)
|
||||
(define btn-add #f)
|
||||
(define btn-edit #f)
|
||||
(define btn-remove #f)
|
||||
(define btn-clear-cache #f)
|
||||
(define lbl-language #f)
|
||||
(define lbl-name #f)
|
||||
(define lbl-kind #f)
|
||||
(define lbl-local-path #f)
|
||||
(define lbl-host #f)
|
||||
(define lbl-lib #f)
|
||||
(define lbl-renderers #f)
|
||||
(define lbl-renderer-name #f)
|
||||
(define lbl-volume-curve #f)
|
||||
(define renderer-body #f)
|
||||
(define div-language #f)
|
||||
(define sel-language #f)
|
||||
|
||||
(define libs
|
||||
(send (get-library-factory)
|
||||
get-libraries-config))
|
||||
|
||||
(define cfg (send settings clone 'settings))
|
||||
|
||||
(define/public (set-labels)
|
||||
(send btn-ok set-innerHTML! (tr 'ok))
|
||||
(send btn-cancel set-innerHTML! (tr 'cancel))
|
||||
(send btn-add set-innerHTML! (tr 'library-add))
|
||||
(send btn-edit set-innerHTML! (tr 'library-edit))
|
||||
(send btn-remove set-innerHTML! (tr 'library-remove))
|
||||
(send btn-clear-cache
|
||||
set-innerHTML!
|
||||
(tr 'clear-cache))
|
||||
(send lbl-language set-innerHTML! (tr 'language))
|
||||
(send lbl-name set-innerHTML! (tr 'name))
|
||||
(send lbl-kind set-innerHTML! (tr 'library-kind))
|
||||
(send lbl-local-path set-innerHTML! (tr 'local-path))
|
||||
(send lbl-host set-innerHTML! (tr 'host))
|
||||
(send lbl-lib set-innerHTML! (tr 'lbl-libary-path))
|
||||
(send lbl-renderers set-innerHTML! (tr 'renderers))
|
||||
(send lbl-renderer-name set-innerHTML! (tr 'name))
|
||||
(send lbl-volume-curve
|
||||
set-innerHTML!
|
||||
(tr 'logarithmic-volume))
|
||||
)
|
||||
|
||||
(define/public (update-renderers)
|
||||
(let ((rows
|
||||
(for/list ((renderer (in-list renderers))
|
||||
(idx (in-naturals)))
|
||||
(list
|
||||
'tr
|
||||
(list (list 'id
|
||||
(format "renderer-~a" idx)))
|
||||
(list 'td
|
||||
'((class "name"))
|
||||
(send renderer get-name))
|
||||
(list
|
||||
'td
|
||||
'((class "volume-curve"))
|
||||
(list
|
||||
'input
|
||||
(append
|
||||
(list
|
||||
'(type "checkbox")
|
||||
'(class "renderer-volume-curve")
|
||||
(list 'id
|
||||
(format "renderer-volume-curve-~a"
|
||||
idx)))
|
||||
(if (eq? (send renderer
|
||||
get-volume-curve)
|
||||
'logarithmic)
|
||||
'((checked "checked"))
|
||||
'()))))))))
|
||||
(send renderer-body
|
||||
set-innerHTML!
|
||||
(apply string-append
|
||||
(map xexpr->string rows)))
|
||||
(send this
|
||||
bind!
|
||||
"table.renderers input.renderer-volume-curve"
|
||||
'change
|
||||
(lambda (el evt data)
|
||||
(let ((idx
|
||||
(string->number
|
||||
(substring
|
||||
(format "~a" (send el id))
|
||||
(string-length
|
||||
"renderer-volume-curve-")))))
|
||||
(send (list-ref renderers idx)
|
||||
set-volume-curve!
|
||||
(if (send el get)
|
||||
'logarithmic
|
||||
'linear)))))))
|
||||
|
||||
(define/public (update-libraries)
|
||||
(let ((count (send libs count)))
|
||||
(letrec ((f (λ (i)
|
||||
(if (= i count)
|
||||
'()
|
||||
(cons
|
||||
(let* ((id (send libs library-id i))
|
||||
(entry (begin
|
||||
(dbg-rktplayer "index = ~a, id = ~a, symbol? id = ~a" i id (symbol? id))
|
||||
(send libs get-library id)))
|
||||
(name (send entry get-name))
|
||||
(kind (send entry get-kind))
|
||||
(local-path (send entry get-root))
|
||||
(host (send entry get-host))
|
||||
(tr-attr (if (send entry is-current?)
|
||||
'((class "current"))
|
||||
'((class "none"))))
|
||||
)
|
||||
(list 'tr (append (list (list 'id (format "~a" id)))
|
||||
tr-attr)
|
||||
(list 'td (list '(class "name")) name)
|
||||
(list 'td (list '(class "kind"))
|
||||
(tr kind))
|
||||
(list 'td '((class "path"))
|
||||
(format "~a" local-path))
|
||||
(list 'td '((class "host"))
|
||||
(or host ""))))
|
||||
(f (+ i 1)))))))
|
||||
(let* ((tbl (f 0))
|
||||
(el (send this element 'lib-body))
|
||||
(html (if (= count 0)
|
||||
""
|
||||
(apply string-append (map xexpr->string tbl)))))
|
||||
(displayln html)
|
||||
(send el set-innerHTML! html)
|
||||
(send this bind! "table.libraries tr" 'click
|
||||
(lambda (el evt data)
|
||||
(let* ((new-id (string->symbol (send el attr 'id)))
|
||||
(new-lib (send libs get-library new-id))
|
||||
(cur-lib (send libs current-library))
|
||||
)
|
||||
(displayln new-id)
|
||||
(displayln new-lib)
|
||||
(displayln cur-lib)
|
||||
(unless (eq? cur-lib #f)
|
||||
(let ((cur-el (send this element (send cur-lib get-id))))
|
||||
(send cur-el remove-class! 'current)
|
||||
(send cur-lib set-current! #f)))
|
||||
(unless (eq? new-id #f)
|
||||
(let ((new-el (send this element new-id)))
|
||||
(displayln new-el)
|
||||
(displayln (send new-el attr 'id))
|
||||
(send new-el set-attr! '(test "NEE!"))
|
||||
(send new-el add-class! "current")
|
||||
(send new-lib set-current! #t)))
|
||||
(libraries-changed-callback)
|
||||
)))
|
||||
))))
|
||||
|
||||
(define/public (add-library)
|
||||
(let* ((cb (λ (id name kind root host item-limit)
|
||||
(send libs add-library
|
||||
(library-item
|
||||
id
|
||||
name
|
||||
kind
|
||||
1
|
||||
root
|
||||
(if (string=? host "")
|
||||
#f
|
||||
host)
|
||||
item-limit
|
||||
#f))
|
||||
(send this update-libraries)
|
||||
(libraries-changed-callback)))
|
||||
(dlg (new library-dlg% [parent this]
|
||||
[settings (send settings clone 'library-dlg)]
|
||||
[kind 'filesystem] [result-cb cb])))
|
||||
(send dlg show)))
|
||||
|
||||
(define/public (edit-library)
|
||||
(let ((entry
|
||||
(send libs current-library)))
|
||||
(when entry
|
||||
(let* ((id (send entry get-id))
|
||||
(kind (send entry get-kind))
|
||||
(kind-version
|
||||
(send entry get-kind-version))
|
||||
(current
|
||||
(send entry is-current?))
|
||||
(cb
|
||||
(lambda (id name kind root host item-limit)
|
||||
(send libs
|
||||
update-item!
|
||||
(library-item
|
||||
id
|
||||
name
|
||||
kind
|
||||
kind-version
|
||||
root
|
||||
(if (string=? host "")
|
||||
#f
|
||||
host)
|
||||
item-limit
|
||||
current))
|
||||
(send this update-libraries)
|
||||
(libraries-changed-callback)))
|
||||
(dlg
|
||||
(new library-dlg%
|
||||
[parent this]
|
||||
[settings
|
||||
(send settings
|
||||
clone
|
||||
'library-dlg)]
|
||||
[id id]
|
||||
[name
|
||||
(send entry get-name)]
|
||||
[kind kind]
|
||||
[kind-editable? #f]
|
||||
[local-path
|
||||
(format
|
||||
"~a"
|
||||
(send entry get-root))]
|
||||
[host
|
||||
(or
|
||||
(send entry get-host)
|
||||
"")]
|
||||
[item-limit
|
||||
(send entry get-item-limit)]
|
||||
[result-cb cb])))
|
||||
(send dlg show)))))
|
||||
|
||||
(define/public (remove-library)
|
||||
(let ((entry
|
||||
(send libs current-library)))
|
||||
(when entry
|
||||
(send libs
|
||||
remove-library
|
||||
(send entry get-id))
|
||||
(let ((new-current
|
||||
(send libs current-library)))
|
||||
(when new-current
|
||||
(send new-current
|
||||
set-current!
|
||||
#t)))
|
||||
(libraries-changed-callback)
|
||||
(send this update-libraries))))
|
||||
|
||||
(define/override (page-loaded oke)
|
||||
(unless initialized
|
||||
(when oke
|
||||
(set! initialized #t)
|
||||
(set! btn-ok (send this element 'ok))
|
||||
(set! btn-cancel (send this element 'cancel))
|
||||
(set! btn-add (send this element 'add))
|
||||
(set! btn-edit (send this element 'edit))
|
||||
(set! btn-remove (send this element 'remove))
|
||||
(set! btn-clear-cache
|
||||
(send this element 'clear-cache))
|
||||
(set! lbl-language (send this element 'lbl-language))
|
||||
(set! lbl-lib (send this element 'lbl-libary-path))
|
||||
(set! lbl-renderers
|
||||
(send this element 'lbl-renderers))
|
||||
(set! lbl-renderer-name
|
||||
(send this element 'lbl-renderer-name))
|
||||
(set! lbl-volume-curve
|
||||
(send this element 'lbl-volume-curve))
|
||||
(set! renderer-body
|
||||
(send this element 'renderer-body))
|
||||
(set! lbl-name (send this element 'lbl-name))
|
||||
(set! lbl-kind (send this element 'lbl-kind))
|
||||
(set! lbl-local-path (send this element 'lbl-local-path))
|
||||
(set! lbl-host (send this element 'lbl-host))
|
||||
(set! div-language (send this element 'language))
|
||||
|
||||
(send this set-labels)
|
||||
|
||||
(send div-language set-innerHTML! (make-select-list 'sel-lang (languages) (current-lang)))
|
||||
|
||||
(send this bind! 'sel-lang 'change (λ (el evt data)
|
||||
(let ((lang (string->symbol
|
||||
(format "~a" (hash-ref data 'value (current-lang))))))
|
||||
(set-lang! lang)
|
||||
(send cfg set! 'language lang)
|
||||
(send this set-labels))))
|
||||
|
||||
(send this bind! 'ok 'click (λ (el evt data) (send this close)))
|
||||
(send this bind! 'cancel 'click (λ (el evt data) (send this close)))
|
||||
(send this bind! 'dev 'click (λ args (send this devtools)))
|
||||
(send this bind! 'add 'click (λ (el evt data) (send this add-library)))
|
||||
(send this bind! 'edit 'click (λ (el evt data) (send this edit-library)))
|
||||
(send this bind! 'remove 'click (λ (el evt data) (send this remove-library)))
|
||||
(send this bind!
|
||||
'clear-cache
|
||||
'click
|
||||
(lambda (el evt data)
|
||||
(cache-cleared-callback)))
|
||||
|
||||
(send this update-libraries)
|
||||
(send this update-renderers)
|
||||
)
|
||||
)
|
||||
(info-rktplayer "page loaded")
|
||||
)
|
||||
|
||||
(begin
|
||||
#t)
|
||||
)
|
||||
)
|
||||
@@ -148,6 +148,9 @@
|
||||
('paused
|
||||
('en "paused")
|
||||
('nl "gepauzeerd"))
|
||||
('starting
|
||||
('en "starting")
|
||||
('nl "starten"))
|
||||
('unknown-state
|
||||
('en "Unknown state")
|
||||
('nl "Onbekende status"))
|
||||
@@ -184,6 +187,36 @@
|
||||
('bits
|
||||
('en "bits")
|
||||
('nl "bits"))
|
||||
('source
|
||||
('en "Source")
|
||||
('nl "Bron"))
|
||||
('downloading-track
|
||||
('en "downloading track ~a: ~a%")
|
||||
('nl "downloaden track ~a : ~a%"))
|
||||
('download-trackcomplete
|
||||
('en "track ~a downloaded")
|
||||
('nl "track ~a gedownload"))
|
||||
('download-track-failed
|
||||
('en "track ~a - download failed")
|
||||
('nl "track ~a - download mislukt"))
|
||||
('playback-failed
|
||||
('en "Could not play: ~a")
|
||||
('nl "Afspelen mislukt: ~a"))
|
||||
('renderer-unreachable
|
||||
('en "Player not reachable: ~a")
|
||||
('nl "Speler niet bereikbaar: ~a"))
|
||||
('renderer-command-failed
|
||||
('en "Player command failed: ~a")
|
||||
('nl "Opdracht aan speler mislukt: ~a"))
|
||||
('clear-cache
|
||||
('en "Clear downloaded tracks")
|
||||
('nl "Verwijder gedownloade tracks"))
|
||||
('renderers
|
||||
('en "Audio Players")
|
||||
('nl "Muziekspelers"))
|
||||
('logarithmic-volume
|
||||
('en "Logarithmic volume")
|
||||
('nl "Logaritmisch volume"))
|
||||
('play
|
||||
('en "Play")
|
||||
('nl "Afspelen"))
|
||||
@@ -212,6 +245,48 @@
|
||||
('en "Search DLNA Players on network")
|
||||
('nl "Zoek DLNA Spelers op het netwerk"))
|
||||
('players
|
||||
('en "Audio Players")
|
||||
('nl "Muziek Spelers"))
|
||||
('en "Audio Players")
|
||||
('nl "Muziek Spelers"))
|
||||
('libraries
|
||||
('en "Music Libraries")
|
||||
('nl "Muziekbibliotheken"))
|
||||
('library-kind
|
||||
('en "Library type")
|
||||
('nl "Bibliotheektype"))
|
||||
('filesystem
|
||||
('en "Filesystem")
|
||||
('nl "Bestandssysteem"))
|
||||
('media-server
|
||||
('en "UPnP media server")
|
||||
('nl "UPnP-mediaserver"))
|
||||
('media-servers
|
||||
('en "Media server")
|
||||
('nl "Mediaserver"))
|
||||
('media-server-root
|
||||
('en "Start point")
|
||||
('nl "Startpunt"))
|
||||
('media-server-item-limit
|
||||
('en "Maximum items per folder")
|
||||
('nl "Maximum aantal items per map"))
|
||||
('select-media-server-container
|
||||
('en "Select a folder")
|
||||
('nl "Selecteer een map"))
|
||||
('no-media-server-containers
|
||||
('en "No folders")
|
||||
('nl "Geen mappen"))
|
||||
('up
|
||||
('en "Up")
|
||||
('nl "Omhoog"))
|
||||
('refresh
|
||||
('en "Refresh")
|
||||
('nl "Vernieuwen"))
|
||||
('searching
|
||||
('en "Searching...")
|
||||
('nl "Zoeken..."))
|
||||
('no-media-servers
|
||||
('en "No media servers found")
|
||||
('nl "Geen mediaservers gevonden"))
|
||||
('library-browse-failed
|
||||
('en "Could not open music library: ~a")
|
||||
('nl "Muziekbibliotheek kon niet worden geopend: ~a"))
|
||||
)
|
||||
@@ -3,12 +3,12 @@
|
||||
(require racket-webview
|
||||
racket/runtime-path
|
||||
"translate.rkt"
|
||||
"utils.rkt"
|
||||
"../misc/utils.rkt"
|
||||
)
|
||||
|
||||
(provide rktplayer-tray%)
|
||||
|
||||
(define-runtime-path rkt-gui-dir "gui")
|
||||
(define-runtime-path rkt-gui-dir "html")
|
||||
|
||||
(define rktplayer-tray%
|
||||
(class wv-tray%
|
||||
@@ -2,7 +2,7 @@
|
||||
|
||||
|
||||
(define pkg-authors '(hnmdijkema))
|
||||
(define version "0.1.1")
|
||||
(define version "0.1.2")
|
||||
(define license 'MIT)
|
||||
(define collection "rktplayer")
|
||||
(define pkg-desc "rktplayer - A music player written in racket")
|
||||
@@ -12,6 +12,10 @@
|
||||
'("racket/gui" "racket/base" "racket"
|
||||
"finalizer" "draw-lib" "net-lib"
|
||||
"simple-log" "simple-ini" "racket-sprintf"
|
||||
"racket-mimetypes"
|
||||
"racket-upnp"
|
||||
"racket-sonos"
|
||||
"racket-audio-dlna"
|
||||
"early-return" "let-assert"
|
||||
"uni-channel" "port-channel"
|
||||
"rackunit-lib"
|
||||
@@ -26,5 +30,3 @@
|
||||
))
|
||||
|
||||
(define test-omit-paths 'all)
|
||||
|
||||
|
||||
|
||||
-125
@@ -1,125 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"utils.rkt"
|
||||
)
|
||||
|
||||
(provide libraries%
|
||||
library%
|
||||
)
|
||||
|
||||
|
||||
(define library%
|
||||
(class object%
|
||||
(init-field [id (new-id)] [name ""] [local-path ""]
|
||||
[host ""] [prefixes ""] [current #f])
|
||||
(super-new)
|
||||
|
||||
(define/public (get-id) id)
|
||||
(define/public (get-name) name)
|
||||
(define/public (get-local-path) local-path)
|
||||
(define/public (get-host) host)
|
||||
(define/public (get-prefixes) prefixes)
|
||||
(define/public (is-current?) current)
|
||||
(define/public (get-current) current)
|
||||
(define/public (set-current! c) (set! current c))
|
||||
(define/public (->list)
|
||||
(list id name local-path host prefixes current))
|
||||
))
|
||||
|
||||
|
||||
(define libraries%
|
||||
(class object%
|
||||
(init-field [settings settings])
|
||||
(super-new)
|
||||
|
||||
(define libs #f)
|
||||
|
||||
(define cfg (send settings clone 'settings))
|
||||
|
||||
(define (to-library e)
|
||||
(let ((f (lambda (id n lp h p . c)
|
||||
(let ((cc (if (null? c) #f (car c))))
|
||||
(new library% [id id]
|
||||
[name n] [local-path lp]
|
||||
[host h] [prefixes p] [current cc])
|
||||
))))
|
||||
(apply f e)
|
||||
)
|
||||
)
|
||||
|
||||
(define (from-library l)
|
||||
(send l ->list))
|
||||
|
||||
(define/public (libraries)
|
||||
(when (eq? libs #f)
|
||||
(let ((cfg-libs (send cfg get 'libraries '())))
|
||||
(dbg-rktplayer "libraries from ini: ~a" cfg-libs)
|
||||
(set! libs (sort (map to-library cfg-libs)
|
||||
(lambda (a b)
|
||||
(string<? (send a get-name) (send b get-name)))))
|
||||
(dbg-rktplayer "libs: ~a" (map (λ (x) (list (send x get-id) (send x get-name))) libs))
|
||||
))
|
||||
libs)
|
||||
|
||||
(define/public (set-libraries! libs*)
|
||||
(send cfg set! 'libraries (map from-library libs*))
|
||||
(set! libs #f))
|
||||
|
||||
(define/public (count)
|
||||
(length (send this libraries)))
|
||||
|
||||
(define/public (library-id idx)
|
||||
(let ((libs (send this libraries)))
|
||||
(if (and (>= idx 0) (< idx (length libs)))
|
||||
(send (list-ref libs idx) get-id)
|
||||
#f)))
|
||||
|
||||
(define/public (get-library id)
|
||||
(let ((libs (send this libraries)))
|
||||
(letrec ((f (λ (libs)
|
||||
(if (null? libs)
|
||||
#f
|
||||
(let* ((lib (car libs))
|
||||
(lib-id (send lib get-id)))
|
||||
(dbg-rktplayer "symbol? lib-id: ~a, lib-id: ~a (~a) eq? ~a" (symbol? lib-id) lib-id (send lib get-name) id)
|
||||
(if (eq? lib-id id)
|
||||
lib
|
||||
(f (cdr libs))))))))
|
||||
(f libs))))
|
||||
|
||||
(define/public (remove-library id)
|
||||
(let ((libs (send this libraries)))
|
||||
(send this set-libraries! (filter (λ (lib)
|
||||
(not (eq? (send lib get-id) id)))
|
||||
libs))))
|
||||
|
||||
(define/public (add-library l)
|
||||
(let ((libs (send this libraries)))
|
||||
(send this set-libraries! (cons l libs))
|
||||
(set! libs #f)
|
||||
(send l get-id)))
|
||||
|
||||
(define/public (update-library l)
|
||||
(let ((libs (send this libraries))
|
||||
(id (send l get-id)))
|
||||
(send this set-libraries! (map (λ (lib)
|
||||
(if (eq? (send lib get-id) id)
|
||||
l
|
||||
lib))
|
||||
libs))))
|
||||
|
||||
(define/public (current-library)
|
||||
(letrec ((f (lambda (libs)
|
||||
(if (null? libs)
|
||||
(if (= (send this count) 0)
|
||||
#f (send this get-library
|
||||
(send this library-id 0)))
|
||||
(let ((l (car libs)))
|
||||
(if (send l is-current?)
|
||||
l
|
||||
(f (cdr libs))))))
|
||||
))
|
||||
(f (send this libraries))))
|
||||
|
||||
))
|
||||
@@ -0,0 +1,12 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class)
|
||||
|
||||
(provide booklet-provider%)
|
||||
|
||||
(define booklet-provider%
|
||||
(class object%
|
||||
(abstract
|
||||
has-booklet?
|
||||
booklet-file)
|
||||
(super-new)))
|
||||
@@ -0,0 +1,13 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class)
|
||||
|
||||
(provide image-provider%)
|
||||
|
||||
(define image-provider%
|
||||
(class object%
|
||||
(abstract
|
||||
has-image?
|
||||
image->file
|
||||
image->mimetype)
|
||||
(super-new)))
|
||||
@@ -0,0 +1,52 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"media-item.rkt")
|
||||
|
||||
(provide media-container%)
|
||||
|
||||
;; A media container contains media-item% instances. An item can itself be
|
||||
;; another media-container%, or it can be a track<%>.
|
||||
(define media-container%
|
||||
(class media-item%
|
||||
(init [id #f])
|
||||
|
||||
(super-new
|
||||
[id id]
|
||||
[kind 'container])
|
||||
|
||||
(abstract
|
||||
get-title
|
||||
get-items
|
||||
get-track-reliver)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define track-reliver
|
||||
(lambda (track-factory-id track-relive-info)
|
||||
(list track-factory-id track-relive-info)))
|
||||
|
||||
(define test-container%
|
||||
(class media-container%
|
||||
(super-new [id 'container-id])
|
||||
|
||||
(define/override (get-title)
|
||||
"Container")
|
||||
|
||||
(define/override (get-items)
|
||||
'())
|
||||
|
||||
(define/override (get-track-reliver)
|
||||
track-reliver)))
|
||||
|
||||
(define container
|
||||
(new test-container%))
|
||||
|
||||
(check-equal? (send container get-id) 'container-id)
|
||||
(check-equal? (send container get-kind) 'container)
|
||||
(check-eq? (send container get-container) container)
|
||||
(check-false (send container get-track))
|
||||
(check-equal? (send container get-title) "Container")
|
||||
(check-equal? (send container get-items) '())
|
||||
(check-eq? (send container get-track-reliver) track-reliver))
|
||||
@@ -0,0 +1,59 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class)
|
||||
|
||||
(provide media-item%)
|
||||
|
||||
;; Common base class for entries returned by a media container.
|
||||
(define media-item%
|
||||
(class object%
|
||||
(init-field
|
||||
kind
|
||||
[id #f])
|
||||
|
||||
(unless (memq kind '(container track))
|
||||
(raise-arguments-error
|
||||
'media-item%
|
||||
"invalid media item kind"
|
||||
"expected" '(container track)
|
||||
"kind" kind))
|
||||
|
||||
(define/public (get-id)
|
||||
id)
|
||||
|
||||
(define/public (get-kind)
|
||||
kind)
|
||||
|
||||
(define/public (get-container)
|
||||
(and (eq? kind 'container)
|
||||
this))
|
||||
|
||||
(define/public (get-track)
|
||||
(and (eq? kind 'track)
|
||||
this))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define container
|
||||
(new media-item%
|
||||
[id 'container-id]
|
||||
[kind 'container]))
|
||||
|
||||
(define track
|
||||
(new media-item%
|
||||
[id 'track-id]
|
||||
[kind 'track]))
|
||||
|
||||
(check-eq? (send container get-container) container)
|
||||
(check-false (send container get-track))
|
||||
(check-eq? (send track get-track) track)
|
||||
(check-false (send track get-container))
|
||||
(check-equal? (send container get-id) 'container-id)
|
||||
(check-equal? (send track get-kind) 'track)
|
||||
(check-exn
|
||||
exn:fail:contract?
|
||||
(lambda ()
|
||||
(new media-item% [kind 'unknown]))))
|
||||
@@ -0,0 +1,51 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"../library-cfg.rkt"
|
||||
"../../misc/utils.rkt")
|
||||
|
||||
(provide media-library%)
|
||||
|
||||
(define media-library%
|
||||
(class object%
|
||||
(init-field
|
||||
cfg)
|
||||
|
||||
(check/c media-library%
|
||||
cfg
|
||||
(is-a?/c library-cfg%))
|
||||
|
||||
(define cfg-revision
|
||||
-1)
|
||||
|
||||
(define root-container
|
||||
#f)
|
||||
|
||||
(define/private (reset-if-needed!)
|
||||
(let ((current-revision (send cfg get-revision)))
|
||||
(unless (= cfg-revision current-revision)
|
||||
(set! cfg-revision current-revision)
|
||||
(set! root-container #f))))
|
||||
|
||||
(define/public (get-cfg)
|
||||
cfg)
|
||||
|
||||
(define/public (get-id)
|
||||
(send cfg get-id))
|
||||
|
||||
(define/public (get-kind)
|
||||
(send cfg get-kind))
|
||||
|
||||
(define/public (get-kind-version)
|
||||
(send cfg get-kind-version))
|
||||
|
||||
(define/public (get-root-container)
|
||||
(reset-if-needed!)
|
||||
(when (eq? root-container #f)
|
||||
(set! root-container
|
||||
(send this make-root-container)))
|
||||
root-container)
|
||||
|
||||
(abstract make-root-container)
|
||||
|
||||
(super-new)))
|
||||
@@ -0,0 +1,97 @@
|
||||
#lang racket/base
|
||||
|
||||
(require net/url
|
||||
racket/class
|
||||
racket/string
|
||||
"../../misc/utils.rkt")
|
||||
|
||||
(provide media-resource%
|
||||
media-resource-file%)
|
||||
|
||||
(define media-resource%
|
||||
(class object%
|
||||
(init-field
|
||||
uri
|
||||
mime-type
|
||||
protocol-info
|
||||
seekable?)
|
||||
|
||||
(check/c* media-resource%
|
||||
(uri string?)
|
||||
(mime-type (or/c #f string?))
|
||||
(protocol-info (or/c #f string?))
|
||||
(seekable? boolean?))
|
||||
|
||||
(define/public (get-uri)
|
||||
uri)
|
||||
|
||||
(define/public (get-mime-type)
|
||||
mime-type)
|
||||
|
||||
(define/public (get-protocol-info)
|
||||
protocol-info)
|
||||
|
||||
(define/public (is-seekable?)
|
||||
seekable?)
|
||||
|
||||
(define/public (get-file)
|
||||
#f)
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define media-resource-file%
|
||||
(class media-resource%
|
||||
(init
|
||||
file
|
||||
mime-type
|
||||
[seekable? #t])
|
||||
|
||||
(check/c media-resource-file%
|
||||
file
|
||||
(or/c path? string?))
|
||||
|
||||
(define resource-file
|
||||
(normal-case-path
|
||||
(path->complete-path file)))
|
||||
|
||||
(define/override (get-file)
|
||||
resource-file)
|
||||
|
||||
(super-new
|
||||
[uri
|
||||
(url->string
|
||||
(path->url resource-file))]
|
||||
[mime-type mime-type]
|
||||
[protocol-info
|
||||
(and mime-type
|
||||
(format "file:*:~a:*" mime-type))]
|
||||
[seekable? seekable?])))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define resource
|
||||
(new media-resource-file%
|
||||
[file
|
||||
(build-path
|
||||
(find-system-path 'temp-dir)
|
||||
"track.flac")]
|
||||
[mime-type "audio/flac"]))
|
||||
|
||||
(check-true
|
||||
(is-a? resource media-resource%))
|
||||
(check-true
|
||||
(is-a? resource media-resource-file%))
|
||||
(check-true
|
||||
(path? (send resource get-file)))
|
||||
(check-true
|
||||
(string-prefix? (send resource get-uri)
|
||||
"file:"))
|
||||
(check-equal?
|
||||
(send resource get-mime-type)
|
||||
"audio/flac")
|
||||
(check-equal?
|
||||
(send resource get-protocol-info)
|
||||
"file:*:audio/flac:*")
|
||||
(check-true
|
||||
(send resource is-seekable?)))
|
||||
@@ -0,0 +1,10 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class)
|
||||
|
||||
(provide tag-data-provider%)
|
||||
|
||||
(define tag-data-provider%
|
||||
(class object%
|
||||
(abstract get-tag-data)
|
||||
(super-new)))
|
||||
@@ -0,0 +1,205 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"booklet-provider.rkt"
|
||||
"image-provider.rkt"
|
||||
"media-item.rkt"
|
||||
"media-resource.rkt"
|
||||
"tag-data-provider.rkt"
|
||||
"../track-tag-data.rkt"
|
||||
"../../misc/utils.rkt")
|
||||
|
||||
(provide track<%>
|
||||
track%)
|
||||
|
||||
(define track<%>
|
||||
(interface ((class->interface media-item%))
|
||||
get-title
|
||||
get-artist
|
||||
get-album
|
||||
get-number
|
||||
get-length
|
||||
get-resource
|
||||
get-music-library-factory-id
|
||||
get-track-factory-id
|
||||
get-track-relive-info
|
||||
has-image?
|
||||
image->file
|
||||
image->mimetype
|
||||
has-booklet?
|
||||
booklet-file
|
||||
track<
|
||||
->log))
|
||||
|
||||
(define next-track-id
|
||||
0)
|
||||
|
||||
(define (new-track-id)
|
||||
(set! next-track-id (+ next-track-id 1))
|
||||
(when (> next-track-id 10000000)
|
||||
(set! next-track-id 1))
|
||||
next-track-id)
|
||||
|
||||
(define track%
|
||||
(class* media-item% (track<%>)
|
||||
(init
|
||||
tag-data-provider
|
||||
image-provider
|
||||
booklet-provider
|
||||
resource
|
||||
[id #f]
|
||||
[music-library-factory-id #f]
|
||||
[track-factory-id #f]
|
||||
[track-relive-info #f])
|
||||
|
||||
(check/c* track%
|
||||
(tag-data-provider
|
||||
(is-a?/c tag-data-provider%))
|
||||
(image-provider
|
||||
(is-a?/c image-provider%))
|
||||
(booklet-provider
|
||||
(is-a?/c booklet-provider%))
|
||||
(resource
|
||||
(is-a?/c media-resource%)))
|
||||
|
||||
(define the-tag-data-provider
|
||||
tag-data-provider)
|
||||
|
||||
(define the-image-provider
|
||||
image-provider)
|
||||
|
||||
(define the-booklet-provider
|
||||
booklet-provider)
|
||||
|
||||
(define the-resource
|
||||
resource)
|
||||
|
||||
(define the-music-library-factory-id
|
||||
music-library-factory-id)
|
||||
|
||||
(define the-track-factory-id
|
||||
track-factory-id)
|
||||
|
||||
(define the-track-relive-info
|
||||
track-relive-info)
|
||||
|
||||
(define/private (get-tag-data)
|
||||
(send the-tag-data-provider get-tag-data))
|
||||
|
||||
(define/public (get-title)
|
||||
(track-tag-data-title (get-tag-data)))
|
||||
|
||||
(define/public (get-artist)
|
||||
(track-tag-data-artist (get-tag-data)))
|
||||
|
||||
(define/public (get-album)
|
||||
(track-tag-data-album (get-tag-data)))
|
||||
|
||||
(define/public (get-number)
|
||||
(track-tag-data-number (get-tag-data)))
|
||||
|
||||
(define/public (get-length)
|
||||
(track-tag-data-length (get-tag-data)))
|
||||
|
||||
(define/public (get-resource)
|
||||
the-resource)
|
||||
|
||||
(define/public (get-music-library-factory-id)
|
||||
the-music-library-factory-id)
|
||||
|
||||
(define/public (get-track-factory-id)
|
||||
the-track-factory-id)
|
||||
|
||||
(define/public (get-track-relive-info)
|
||||
the-track-relive-info)
|
||||
|
||||
(define/public (has-image?)
|
||||
(send the-image-provider has-image?))
|
||||
|
||||
(define/public (image->file target-file)
|
||||
(send the-image-provider image->file target-file))
|
||||
|
||||
(define/public (image->mimetype)
|
||||
(send the-image-provider image->mimetype))
|
||||
|
||||
(define/public (has-booklet?)
|
||||
(send the-booklet-provider has-booklet?))
|
||||
|
||||
(define/public (booklet-file)
|
||||
(send the-booklet-provider booklet-file))
|
||||
|
||||
(define/public (track< other-track)
|
||||
(if (string-ci<? (send this get-album)
|
||||
(send other-track get-album))
|
||||
#t
|
||||
(and (string-ci=? (send this get-album)
|
||||
(send other-track get-album))
|
||||
(< (send this get-number)
|
||||
(send other-track get-number)))))
|
||||
|
||||
(define/public (->log)
|
||||
(info-rktplayer "~a - ~a - ~a - ~a"
|
||||
(send this get-number)
|
||||
(send this get-title)
|
||||
(send this get-album)
|
||||
(send this get-length)))
|
||||
|
||||
(super-new
|
||||
[id (if id id (new-track-id))]
|
||||
[kind 'track])))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define test-tag-data-provider%
|
||||
(class tag-data-provider%
|
||||
(define/override (get-tag-data)
|
||||
(track-tag-data
|
||||
"Title"
|
||||
"Artist"
|
||||
"Album"
|
||||
2
|
||||
120))
|
||||
(super-new)))
|
||||
|
||||
(define test-image-provider%
|
||||
(class image-provider%
|
||||
(define/override (has-image?) #f)
|
||||
(define/override (image->file target-file) #f)
|
||||
(define/override (image->mimetype) 'no-mimetype)
|
||||
(super-new)))
|
||||
|
||||
(define test-booklet-provider%
|
||||
(class booklet-provider%
|
||||
(define/override (has-booklet?) #f)
|
||||
(define/override (booklet-file) #f)
|
||||
(super-new)))
|
||||
|
||||
(define resource
|
||||
(new media-resource%
|
||||
[uri "https://example.com/track.flac"]
|
||||
[mime-type "audio/flac"]
|
||||
[protocol-info "http-get:*:audio/flac:*"]
|
||||
[seekable? #t]))
|
||||
|
||||
(define track
|
||||
(new track%
|
||||
[resource resource]
|
||||
[tag-data-provider
|
||||
(new test-tag-data-provider%)]
|
||||
[image-provider
|
||||
(new test-image-provider%)]
|
||||
[booklet-provider
|
||||
(new test-booklet-provider%)]))
|
||||
|
||||
(check-true (is-a? track track%))
|
||||
(check-true (is-a? track track<%>))
|
||||
(check-equal? (send track get-kind) 'track)
|
||||
(check-equal? (send track get-title) "Title")
|
||||
(check-equal? (send track get-artist) "Artist")
|
||||
(check-equal? (send track get-album) "Album")
|
||||
(check-equal? (send track get-number) 2)
|
||||
(check-equal? (send track get-length) 120)
|
||||
(check-eq? (send track get-resource) resource)
|
||||
(check-false (send track has-image?))
|
||||
(check-false (send track has-booklet?)))
|
||||
@@ -0,0 +1,149 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"library-cfg.rkt"
|
||||
"library-item.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide libraries-config%
|
||||
(all-from-out "library-cfg.rkt")
|
||||
(all-from-out "library-item.rkt"))
|
||||
|
||||
(define libraries-config%
|
||||
(class object%
|
||||
(init-field settings)
|
||||
|
||||
(define items
|
||||
#f)
|
||||
|
||||
(define revisions
|
||||
(make-hash))
|
||||
|
||||
(define cfg
|
||||
(send settings clone 'settings))
|
||||
|
||||
(define/private (sorted-items value)
|
||||
(sort value
|
||||
(lambda (a b)
|
||||
(string<? (library-item-name a)
|
||||
(library-item-name b)))))
|
||||
|
||||
(define/private (get-items)
|
||||
(when (eq? items #f)
|
||||
(let ((stored (send cfg get 'libraries '())))
|
||||
(dbg-rktplayer "libraries from ini: ~a" stored)
|
||||
(set! items
|
||||
(sorted-items
|
||||
(map store->library-item stored)))))
|
||||
items)
|
||||
|
||||
(define/private (store-items! value)
|
||||
(let ((new-items (sorted-items value)))
|
||||
(send cfg
|
||||
set!
|
||||
'libraries
|
||||
(map library-item->store new-items))
|
||||
(set! items new-items)))
|
||||
|
||||
(define/private (increment-revision! id)
|
||||
(hash-update! revisions id add1 0))
|
||||
|
||||
(define/public (libraries)
|
||||
(map (lambda (item)
|
||||
(new library-cfg%
|
||||
[library-cfg-id (library-item-id item)]
|
||||
[libraries-config this]))
|
||||
(get-items)))
|
||||
|
||||
(define/public (count)
|
||||
(length (get-items)))
|
||||
|
||||
(define/public (library-id idx)
|
||||
(let ((all-items (get-items)))
|
||||
(if (and (>= idx 0)
|
||||
(< idx (length all-items)))
|
||||
(library-item-id (list-ref all-items idx))
|
||||
#f)))
|
||||
|
||||
(define/public (get-item id)
|
||||
(check/c libraries-config% get-item id symbol?)
|
||||
(findf (lambda (item)
|
||||
(eq? (library-item-id item) id))
|
||||
(get-items)))
|
||||
|
||||
(define/public (get-item-revision id)
|
||||
(check/c libraries-config% get-item-revision id symbol?)
|
||||
(hash-ref revisions id 0))
|
||||
|
||||
(define/public (get-library id)
|
||||
(check/c libraries-config% get-library id symbol?)
|
||||
(and (send this get-item id)
|
||||
(new library-cfg%
|
||||
[library-cfg-id id]
|
||||
[libraries-config this])))
|
||||
|
||||
(define/public (remove-library id)
|
||||
(check/c libraries-config% remove-library id symbol?)
|
||||
(store-items!
|
||||
(filter (lambda (item)
|
||||
(not (eq? (library-item-id item) id)))
|
||||
(get-items)))
|
||||
(increment-revision! id))
|
||||
|
||||
(define/public (add-library item)
|
||||
(check/c libraries-config% add-library item library-item?)
|
||||
|
||||
(let ((id (library-item-id item)))
|
||||
(when (send this get-item id)
|
||||
(raise-arguments-error
|
||||
'libraries-config%:add-library
|
||||
"a library with this id already exists"
|
||||
"id" id))
|
||||
|
||||
(store-items! (cons item (get-items)))
|
||||
(increment-revision! id)
|
||||
id))
|
||||
|
||||
(define/public (update-item! item)
|
||||
(check/c libraries-config% update-item! item library-item?)
|
||||
|
||||
(let* ((id (library-item-id item))
|
||||
(current-item (send this get-item id)))
|
||||
(unless current-item
|
||||
(raise-arguments-error
|
||||
'libraries-config%:update-item!
|
||||
"library does not exist"
|
||||
"id" id))
|
||||
|
||||
(unless (and (eq? (library-item-kind current-item)
|
||||
(library-item-kind item))
|
||||
(= (library-item-kind-version current-item)
|
||||
(library-item-kind-version item)))
|
||||
(raise-arguments-error
|
||||
'libraries-config%:update-item!
|
||||
"library kind and kind-version cannot be changed"
|
||||
"id" id))
|
||||
|
||||
(store-items!
|
||||
(map (lambda (existing)
|
||||
(if (eq? (library-item-id existing) id)
|
||||
item
|
||||
existing))
|
||||
(get-items)))
|
||||
(increment-revision! id)
|
||||
(void)))
|
||||
|
||||
(define/public (current-library)
|
||||
(let ((item
|
||||
(findf library-item-current
|
||||
(get-items))))
|
||||
(if item
|
||||
(send this get-library
|
||||
(library-item-id item))
|
||||
(if (null? (get-items))
|
||||
#f
|
||||
(send this get-library
|
||||
(library-item-id
|
||||
(car (get-items))))))))
|
||||
|
||||
(super-new)))
|
||||
@@ -0,0 +1,82 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"base/media-container.rkt"
|
||||
"base/media-library.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide library-browser%)
|
||||
|
||||
(define library-browser%
|
||||
(class object%
|
||||
(init-field media-library)
|
||||
|
||||
(check/c library-browser%
|
||||
media-library
|
||||
(is-a?/c media-library%))
|
||||
|
||||
(define current-container
|
||||
#f)
|
||||
|
||||
(define parent-containers
|
||||
'())
|
||||
|
||||
(define cfg-revision
|
||||
-1)
|
||||
|
||||
(define/private (reset-if-needed!)
|
||||
(let ((current-revision
|
||||
(send (send media-library get-cfg)
|
||||
get-revision)))
|
||||
(unless (= cfg-revision current-revision)
|
||||
(set! cfg-revision current-revision)
|
||||
(send this reset!))))
|
||||
|
||||
(define/public (get-media-library)
|
||||
media-library)
|
||||
|
||||
(define/public (get-current-container)
|
||||
(reset-if-needed!)
|
||||
current-container)
|
||||
|
||||
(define/public (get-items)
|
||||
(send (send this get-current-container)
|
||||
get-items))
|
||||
|
||||
(define/public (can-go-up?)
|
||||
(reset-if-needed!)
|
||||
(not (null? parent-containers)))
|
||||
|
||||
(define/public (open-container! container)
|
||||
(check/c library-browser% open-container!
|
||||
container
|
||||
(is-a?/c media-container%))
|
||||
|
||||
(reset-if-needed!)
|
||||
(set! parent-containers
|
||||
(cons current-container
|
||||
parent-containers))
|
||||
(set! current-container container)
|
||||
(void))
|
||||
|
||||
(define/public (go-up!)
|
||||
(reset-if-needed!)
|
||||
(unless (null? parent-containers)
|
||||
(set! current-container
|
||||
(car parent-containers))
|
||||
(set! parent-containers
|
||||
(cdr parent-containers)))
|
||||
(void))
|
||||
|
||||
(define/public (reset!)
|
||||
(set! cfg-revision
|
||||
(send (send media-library get-cfg)
|
||||
get-revision))
|
||||
(set! current-container
|
||||
(send media-library get-root-container))
|
||||
(set! parent-containers '())
|
||||
(void))
|
||||
|
||||
(super-new)
|
||||
|
||||
(send this reset!)))
|
||||
@@ -0,0 +1,71 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"library-item.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide library-cfg%)
|
||||
|
||||
(define library-cfg%
|
||||
(class object%
|
||||
(init-field
|
||||
library-cfg-id
|
||||
libraries-config)
|
||||
|
||||
(check/c* library-cfg%
|
||||
(library-cfg-id symbol?)
|
||||
(libraries-config object?))
|
||||
|
||||
(define/private (get-item)
|
||||
(let ((item (send libraries-config
|
||||
get-item
|
||||
library-cfg-id)))
|
||||
(unless item
|
||||
(raise-arguments-error
|
||||
'library-cfg%
|
||||
"library configuration no longer exists"
|
||||
"library-cfg-id" library-cfg-id))
|
||||
item))
|
||||
|
||||
(define/public (get-id)
|
||||
library-cfg-id)
|
||||
|
||||
(define/public (get-name)
|
||||
(library-item-name (get-item)))
|
||||
|
||||
(define/public (get-kind)
|
||||
(library-item-kind (get-item)))
|
||||
|
||||
(define/public (get-kind-version)
|
||||
(library-item-kind-version (get-item)))
|
||||
|
||||
(define/public (get-root)
|
||||
(library-item-root (get-item)))
|
||||
|
||||
(define/public (get-host)
|
||||
(library-item-host (get-item)))
|
||||
|
||||
(define/public (get-item-limit)
|
||||
(library-item-item-limit (get-item)))
|
||||
|
||||
(define/public (is-current?)
|
||||
(library-item-current (get-item)))
|
||||
|
||||
(define/public (get-current)
|
||||
(library-item-current (get-item)))
|
||||
|
||||
(define/public (get-revision)
|
||||
(send libraries-config
|
||||
get-item-revision
|
||||
library-cfg-id))
|
||||
|
||||
(define/public (set-current! value)
|
||||
(check/c library-cfg% set-current! value boolean?)
|
||||
|
||||
(send libraries-config
|
||||
update-item!
|
||||
(struct-copy library-item
|
||||
(get-item)
|
||||
[current value])))
|
||||
|
||||
(super-new)))
|
||||
@@ -0,0 +1,108 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"libraries-config.rkt"
|
||||
"base/media-library.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide library-factory%
|
||||
get-library-factory
|
||||
set-library-factory!)
|
||||
|
||||
(define current-library-factory
|
||||
#f)
|
||||
|
||||
(define (get-library-factory)
|
||||
(unless current-library-factory
|
||||
(raise-arguments-error
|
||||
'get-library-factory
|
||||
"no library factory has been configured"))
|
||||
current-library-factory)
|
||||
|
||||
(define (set-library-factory! factory)
|
||||
(check/c set-library-factory!
|
||||
factory
|
||||
(is-a?/c library-factory%))
|
||||
(set! current-library-factory factory)
|
||||
(void))
|
||||
|
||||
(define library-factory%
|
||||
(class object%
|
||||
(init-field libraries-config)
|
||||
|
||||
(check/c library-factory%
|
||||
libraries-config
|
||||
(is-a?/c libraries-config%))
|
||||
|
||||
(define makers
|
||||
(make-hash))
|
||||
|
||||
(define libraries
|
||||
(make-hash))
|
||||
|
||||
(define/public (get-libraries-config)
|
||||
libraries-config)
|
||||
|
||||
(define/public (register-library-maker! kind version maker)
|
||||
(check/c* (library-factory% register-library-maker!)
|
||||
(kind symbol?)
|
||||
(version exact-positive-integer?)
|
||||
(maker (-> (is-a?/c library-cfg%) any/c)))
|
||||
|
||||
(let ((maker-key (cons kind version)))
|
||||
(when (hash-has-key? makers maker-key)
|
||||
(raise-arguments-error
|
||||
'library-factory%:register-library-maker!
|
||||
"a library maker is already registered"
|
||||
"kind" kind
|
||||
"version" version))
|
||||
|
||||
(hash-set! makers maker-key maker)
|
||||
(void)))
|
||||
|
||||
(define/public (get-library library-id kind version)
|
||||
(check/c* (library-factory% get-library)
|
||||
(library-id symbol?)
|
||||
(kind symbol?)
|
||||
(version exact-positive-integer?))
|
||||
|
||||
(hash-ref!
|
||||
libraries
|
||||
library-id
|
||||
(lambda ()
|
||||
(let ((cfg (send libraries-config
|
||||
get-library
|
||||
library-id)))
|
||||
(unless cfg
|
||||
(raise-arguments-error
|
||||
'library-factory%:get-library
|
||||
"library configuration does not exist"
|
||||
"library-id" library-id))
|
||||
|
||||
(unless (and (eq? kind (send cfg get-kind))
|
||||
(= version (send cfg get-kind-version)))
|
||||
(raise-arguments-error
|
||||
'library-factory%:get-library
|
||||
"library kind or version does not match its configuration"
|
||||
"library-id" library-id
|
||||
"kind" kind
|
||||
"version" version))
|
||||
|
||||
(let* ((maker-key (cons kind version))
|
||||
(maker
|
||||
(hash-ref
|
||||
makers
|
||||
maker-key
|
||||
(lambda ()
|
||||
(raise-arguments-error
|
||||
'library-factory%:get-library
|
||||
"no library maker is registered"
|
||||
"kind" kind
|
||||
"version" version))))
|
||||
(library (maker cfg)))
|
||||
(check/c library-factory% get-library
|
||||
library
|
||||
(is-a?/c media-library%))
|
||||
library)))))
|
||||
|
||||
(super-new)))
|
||||
@@ -0,0 +1,66 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
"mc-filesystem.rkt"
|
||||
"library-factory.rkt"
|
||||
"base/media-library.rkt"
|
||||
"track-filesystem.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide library-filesystem%
|
||||
register-library-filesystem!)
|
||||
|
||||
(define library-filesystem-kind
|
||||
'filesystem)
|
||||
|
||||
(define library-filesystem-version
|
||||
1)
|
||||
|
||||
(define (register-library-filesystem! factory)
|
||||
(check/c register-library-filesystem!
|
||||
factory
|
||||
(is-a?/c library-factory%))
|
||||
|
||||
(send factory
|
||||
register-library-maker!
|
||||
library-filesystem-kind
|
||||
library-filesystem-version
|
||||
(lambda (cfg)
|
||||
(new library-filesystem%
|
||||
[cfg cfg]))))
|
||||
|
||||
(define library-filesystem%
|
||||
(class media-library%
|
||||
(init
|
||||
cfg)
|
||||
|
||||
(define/override (make-root-container)
|
||||
(new mc-filesystem%
|
||||
[library this]
|
||||
[relative-path '()]))
|
||||
|
||||
(define/public (make-container relative-path)
|
||||
(new mc-filesystem%
|
||||
[library this]
|
||||
[relative-path relative-path]))
|
||||
|
||||
(define/public (make-track relative-path)
|
||||
(new track-filesystem%
|
||||
[library this]
|
||||
[relative-path relative-path]))
|
||||
|
||||
(define/public (resolve-path relative-path)
|
||||
(check/c library-filesystem% resolve-path
|
||||
relative-path
|
||||
list?)
|
||||
|
||||
(let ((root
|
||||
(normal-case-path
|
||||
(send (send this get-cfg)
|
||||
get-root))))
|
||||
(if (null? relative-path)
|
||||
root
|
||||
(apply build-path root relative-path))))
|
||||
|
||||
(super-new
|
||||
[cfg cfg])))
|
||||
@@ -0,0 +1,74 @@
|
||||
#lang racket/base
|
||||
|
||||
(require "../misc/utils.rkt")
|
||||
|
||||
(provide
|
||||
(struct-out library-item)
|
||||
library-item->store
|
||||
store->library-item)
|
||||
|
||||
(define library-item-store-version
|
||||
1)
|
||||
|
||||
(struct library-item
|
||||
(id
|
||||
name
|
||||
kind
|
||||
kind-version
|
||||
root
|
||||
host
|
||||
item-limit
|
||||
current)
|
||||
#:transparent
|
||||
#:guard
|
||||
(lambda (id name kind kind-version root host item-limit current type-name)
|
||||
(check/c* library-item
|
||||
(id symbol?)
|
||||
(name string?)
|
||||
(kind (or/c 'filesystem 'media-server))
|
||||
(kind-version exact-positive-integer?)
|
||||
(root (or/c path? string?))
|
||||
(host (or/c #f string?))
|
||||
(item-limit exact-positive-integer?)
|
||||
(current boolean?))
|
||||
(values id
|
||||
name
|
||||
kind
|
||||
kind-version
|
||||
root
|
||||
host
|
||||
item-limit
|
||||
current)))
|
||||
|
||||
(define (library-item->store item)
|
||||
(check/c library-item->store item library-item?)
|
||||
|
||||
(let ((root (library-item-root item)))
|
||||
(hash
|
||||
'version library-item-store-version
|
||||
'id (library-item-id item)
|
||||
'name (library-item-name item)
|
||||
'kind (library-item-kind item)
|
||||
'kind-version (library-item-kind-version item)
|
||||
'root (if (path? root) (path->string root) root)
|
||||
'host (library-item-host item)
|
||||
'item-limit (library-item-item-limit item)
|
||||
'current (library-item-current item))))
|
||||
|
||||
(define (store->library-item stored)
|
||||
(check/c store->library-item stored hash?)
|
||||
|
||||
(let ((version (hash-ref stored 'version #f)))
|
||||
(check/c store->library-item
|
||||
version
|
||||
(=/c library-item-store-version))
|
||||
|
||||
(library-item
|
||||
(hash-ref stored 'id)
|
||||
(hash-ref stored 'name)
|
||||
(hash-ref stored 'kind)
|
||||
(hash-ref stored 'kind-version)
|
||||
(hash-ref stored 'root)
|
||||
(hash-ref stored 'host)
|
||||
(hash-ref stored 'item-limit 100)
|
||||
(hash-ref stored 'current))))
|
||||
@@ -0,0 +1,219 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket/list
|
||||
racket/match
|
||||
racket/string
|
||||
(prefix-in upnp: racket-upnp)
|
||||
"library-factory.rkt"
|
||||
"mc-media-server.rkt"
|
||||
"base/media-library.rkt"
|
||||
"track-media-server.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide library-media-server%
|
||||
register-library-media-server!)
|
||||
|
||||
(define library-media-server-kind
|
||||
'media-server)
|
||||
|
||||
(define library-media-server-version
|
||||
1)
|
||||
|
||||
(define (register-library-media-server! factory)
|
||||
(check/c register-library-media-server!
|
||||
factory
|
||||
(is-a?/c library-factory%))
|
||||
|
||||
(send factory
|
||||
register-library-maker!
|
||||
library-media-server-kind
|
||||
library-media-server-version
|
||||
(lambda (cfg)
|
||||
(new library-media-server%
|
||||
[cfg cfg]))))
|
||||
|
||||
(define library-media-server%
|
||||
(class media-library%
|
||||
(init
|
||||
cfg)
|
||||
|
||||
(define server
|
||||
#f)
|
||||
|
||||
(define server-cfg-revision
|
||||
-1)
|
||||
|
||||
(define/private (server-selector)
|
||||
(or (send (send this get-cfg)
|
||||
get-host)
|
||||
(send (send this get-cfg)
|
||||
get-name)))
|
||||
|
||||
(define/private (server-matches? candidate selector)
|
||||
(let ((name
|
||||
(upnp:media-server-name candidate))
|
||||
(address
|
||||
(upnp:media-server-address candidate))
|
||||
(udn
|
||||
(upnp:upnp-device-udn candidate)))
|
||||
(or
|
||||
(and udn
|
||||
(string-ci=? udn selector))
|
||||
(and name
|
||||
(string-ci=? name selector))
|
||||
(and address
|
||||
(string-ci=? address selector))
|
||||
(and name
|
||||
(string-contains?
|
||||
(string-downcase name)
|
||||
(string-downcase selector))))))
|
||||
|
||||
(define/private (get-server)
|
||||
(let ((cfg-revision
|
||||
(send (send this get-cfg)
|
||||
get-revision)))
|
||||
(unless (= cfg-revision
|
||||
server-cfg-revision)
|
||||
(set! server #f)
|
||||
(set! server-cfg-revision
|
||||
cfg-revision))
|
||||
(unless server
|
||||
(let* ((selector (server-selector))
|
||||
(found
|
||||
(findf
|
||||
(lambda (candidate)
|
||||
(server-matches?
|
||||
candidate
|
||||
selector))
|
||||
(upnp:query-media-servers))))
|
||||
(unless found
|
||||
(raise-arguments-error
|
||||
'library-media-server%
|
||||
"configured media server was not found"
|
||||
"selector" selector))
|
||||
(set! server found)))
|
||||
server))
|
||||
|
||||
(define/private (root-container-id)
|
||||
(format "~a"
|
||||
(send (send this get-cfg)
|
||||
get-root)))
|
||||
|
||||
(define/private (browse-page container-id start count)
|
||||
(with-handlers
|
||||
(((lambda (exception)
|
||||
(and
|
||||
(upnp:exn:fail:upnp? exception)
|
||||
(equal?
|
||||
(format "~a"
|
||||
(upnp:exn:fail:upnp-code
|
||||
exception))
|
||||
"701")
|
||||
(equal? container-id
|
||||
(root-container-id))
|
||||
(not (string=? container-id
|
||||
"0"))))
|
||||
(lambda (exception)
|
||||
(warn-rktplayer
|
||||
(string-append
|
||||
"Configured UPnP media-server root ~a "
|
||||
"does not exist; browsing root 0")
|
||||
container-id)
|
||||
(upnp:media-server-browse
|
||||
(get-server)
|
||||
"0"
|
||||
#:start start
|
||||
#:count count))))
|
||||
(upnp:media-server-browse
|
||||
(get-server)
|
||||
container-id
|
||||
#:start start
|
||||
#:count count)))
|
||||
|
||||
(define/public (browse-container container-id)
|
||||
(check/c library-media-server% browse-container
|
||||
container-id
|
||||
string?)
|
||||
|
||||
(browse-page
|
||||
container-id
|
||||
0
|
||||
(send (send this get-cfg)
|
||||
get-item-limit)))
|
||||
|
||||
(define/private (find-entry parent-id entry-id)
|
||||
(let ((page-size
|
||||
(send (send this get-cfg)
|
||||
get-item-limit)))
|
||||
(let loop ((start 0))
|
||||
(let* ((entries
|
||||
(browse-page parent-id
|
||||
start
|
||||
page-size))
|
||||
(entry
|
||||
(findf
|
||||
(lambda (candidate)
|
||||
(equal?
|
||||
(upnp:media-entry-id candidate)
|
||||
entry-id))
|
||||
entries)))
|
||||
(cond
|
||||
(entry entry)
|
||||
((< (length entries)
|
||||
page-size)
|
||||
#f)
|
||||
(else
|
||||
(loop (+ start
|
||||
page-size))))))))
|
||||
|
||||
(define/override (make-root-container)
|
||||
(new mc-media-server%
|
||||
[library this]
|
||||
[container-id
|
||||
(root-container-id)]
|
||||
[title
|
||||
(send (send this get-cfg)
|
||||
get-name)]))
|
||||
|
||||
(define/public (make-container entry)
|
||||
(check/c library-media-server% make-container
|
||||
entry
|
||||
upnp:media-container?)
|
||||
|
||||
(new mc-media-server%
|
||||
[library this]
|
||||
[container-id
|
||||
(upnp:media-entry-id entry)]
|
||||
[title
|
||||
(upnp:media-entry-title entry)]))
|
||||
|
||||
(define/public (make-track entry)
|
||||
(check/c library-media-server% make-track
|
||||
entry
|
||||
upnp:media-item?)
|
||||
|
||||
(new track-media-server%
|
||||
[library this]
|
||||
[entry entry]))
|
||||
|
||||
(define/public (relive-track track-factory-id
|
||||
track-relive-info)
|
||||
(case track-factory-id
|
||||
((media-server-item)
|
||||
(match track-relive-info
|
||||
((list (? string? parent-id)
|
||||
(? string? entry-id))
|
||||
(let ((entry
|
||||
(find-entry parent-id
|
||||
entry-id)))
|
||||
(and entry
|
||||
(upnp:media-item? entry)
|
||||
(send this
|
||||
make-track
|
||||
entry))))
|
||||
(else #f)))
|
||||
(else #f)))
|
||||
|
||||
(super-new
|
||||
[cfg cfg])))
|
||||
@@ -0,0 +1,7 @@
|
||||
#lang racket/base
|
||||
|
||||
(provide (struct-out library-ref))
|
||||
|
||||
(struct library-ref
|
||||
(library-id kind version)
|
||||
#:prefab)
|
||||
@@ -0,0 +1,82 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket-audio
|
||||
racket/list
|
||||
racket/path
|
||||
racket/string
|
||||
"base/media-container.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide mc-filesystem%)
|
||||
|
||||
(define mc-filesystem%
|
||||
(class media-container%
|
||||
(init-field
|
||||
library
|
||||
[relative-path '()])
|
||||
|
||||
(check/c mc-filesystem% relative-path list?)
|
||||
|
||||
(define/private (full-path)
|
||||
(send library resolve-path relative-path))
|
||||
|
||||
(define/private (music-file-name? path)
|
||||
(let ((file-name
|
||||
(string-downcase (path->string path))))
|
||||
(for/or ((extension
|
||||
(in-list (audio-known-exts?))))
|
||||
(string-suffix?
|
||||
file-name
|
||||
(string-append "." extension)))))
|
||||
|
||||
(define/private (item-kind path)
|
||||
(cond
|
||||
((directory-exists? path)
|
||||
(let ((name
|
||||
(path->string
|
||||
(file-name-from-path path))))
|
||||
(and (not (string-prefix? name "."))
|
||||
'container)))
|
||||
((music-file-name? path) 'track)
|
||||
(else #f)))
|
||||
|
||||
(define/override (get-title)
|
||||
(if (null? relative-path)
|
||||
(send (send library get-cfg) get-name)
|
||||
(path->string (last relative-path))))
|
||||
|
||||
(define/override (get-items)
|
||||
(let ((path (full-path)))
|
||||
(if (directory-exists? path)
|
||||
(for*/list ((entry (in-list
|
||||
(sort (directory-list path)
|
||||
path<?)))
|
||||
(entry-path
|
||||
(in-value (build-path path entry)))
|
||||
(kind
|
||||
(in-value (item-kind entry-path)))
|
||||
#:when kind)
|
||||
(let ((entry-relative-path
|
||||
(append relative-path (list entry))))
|
||||
(if (eq? kind 'container)
|
||||
(send library
|
||||
make-container
|
||||
entry-relative-path)
|
||||
(send library
|
||||
make-track
|
||||
entry-relative-path))))
|
||||
'())))
|
||||
|
||||
(define/override (get-track-reliver)
|
||||
(lambda (track-factory-id track-relive-info)
|
||||
(case track-factory-id
|
||||
((file)
|
||||
(send library
|
||||
make-track
|
||||
track-relive-info))
|
||||
(else #f))))
|
||||
|
||||
(super-new
|
||||
[id (cons (send (send library get-cfg) get-id)
|
||||
relative-path)])))
|
||||
@@ -0,0 +1,86 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket/list
|
||||
racket/string
|
||||
(prefix-in upnp: racket-upnp)
|
||||
"base/media-container.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide mc-media-server%)
|
||||
|
||||
(define mc-media-server%
|
||||
(class media-container%
|
||||
(init-field
|
||||
library
|
||||
container-id
|
||||
title)
|
||||
|
||||
(check/c* mc-media-server%
|
||||
(library object?)
|
||||
(container-id string?)
|
||||
(title string?))
|
||||
|
||||
(define/private (audio-item? entry)
|
||||
(and
|
||||
(upnp:media-item? entry)
|
||||
(string? (upnp:media-entry-id entry))
|
||||
(string? (upnp:media-entry-parent-id entry))
|
||||
(not
|
||||
(null?
|
||||
(upnp:media-item-resources entry)))
|
||||
(or
|
||||
(let ((class
|
||||
(upnp:media-entry-class entry)))
|
||||
(and class
|
||||
(string-prefix?
|
||||
class
|
||||
"object.item.audioItem")))
|
||||
(for/or
|
||||
((resource
|
||||
(in-list
|
||||
(upnp:media-item-resources entry))))
|
||||
(let ((content-type
|
||||
(upnp:media-resource-content-type
|
||||
resource)))
|
||||
(and content-type
|
||||
(string-prefix?
|
||||
content-type
|
||||
"audio/")))))))
|
||||
|
||||
(define/override (get-title)
|
||||
title)
|
||||
|
||||
(define/override (get-items)
|
||||
(filter-map
|
||||
(lambda (entry)
|
||||
(cond
|
||||
((and (upnp:media-container? entry)
|
||||
(string?
|
||||
(upnp:media-entry-id entry)))
|
||||
(send library
|
||||
make-container
|
||||
entry))
|
||||
((audio-item? entry)
|
||||
(send library
|
||||
make-track
|
||||
entry))
|
||||
(else #f)))
|
||||
(send library
|
||||
browse-container
|
||||
container-id)))
|
||||
|
||||
(define/override (get-track-reliver)
|
||||
(lambda (track-factory-id
|
||||
track-relive-info)
|
||||
(send library
|
||||
relive-track
|
||||
track-factory-id
|
||||
track-relive-info)))
|
||||
|
||||
(super-new
|
||||
[id
|
||||
(cons
|
||||
(send (send library get-cfg)
|
||||
get-id)
|
||||
container-id)])))
|
||||
@@ -0,0 +1,159 @@
|
||||
#lang racket
|
||||
|
||||
(require racket-audio
|
||||
"base/booklet-provider.rkt"
|
||||
"base/image-provider.rkt"
|
||||
"base/tag-data-provider.rkt"
|
||||
"track-tag-data.rkt")
|
||||
|
||||
(provide tag-source-filesystem%
|
||||
tag-data-provider-filesystem%
|
||||
image-provider-filesystem%
|
||||
booklet-provider-filesystem%)
|
||||
|
||||
(define tag-source-filesystem%
|
||||
(class object%
|
||||
(init-field file)
|
||||
|
||||
(define tags
|
||||
#f)
|
||||
|
||||
(define loaded?
|
||||
#f)
|
||||
|
||||
(define/private (read-tags)
|
||||
(if (and file (file-exists? file))
|
||||
(let* ((source-file
|
||||
(if (path? file)
|
||||
(path->string file)
|
||||
file))
|
||||
(source-tags (id3-tags source-file)))
|
||||
(if (tags-valid? source-tags)
|
||||
source-tags
|
||||
(let ((temporary-file
|
||||
(make-temporary-file
|
||||
"rktplayer-~a"
|
||||
#:copy-from source-file)))
|
||||
(let ((temporary-tags
|
||||
(id3-tags temporary-file)))
|
||||
(delete-file temporary-file)
|
||||
temporary-tags))))
|
||||
#f))
|
||||
|
||||
(define/public (get-tags)
|
||||
(unless loaded?
|
||||
(set! tags (read-tags))
|
||||
(set! loaded? #t))
|
||||
tags)
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define tag-data-provider-filesystem%
|
||||
(class tag-data-provider%
|
||||
(init-field
|
||||
tag-source
|
||||
[fallback-data (track-tag-data "" "" "" 0 0)])
|
||||
|
||||
(define tag-data
|
||||
#f)
|
||||
|
||||
(define/override (get-tag-data)
|
||||
(unless tag-data
|
||||
(let ((tags (send tag-source get-tags)))
|
||||
(set! tag-data
|
||||
(if (and tags (tags-valid? tags))
|
||||
(track-tag-data
|
||||
(tags-title tags)
|
||||
(tags-artist tags)
|
||||
(tags-album tags)
|
||||
(tags-track tags)
|
||||
(tags-length tags))
|
||||
fallback-data))))
|
||||
tag-data)
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define image-provider-filesystem%
|
||||
(class image-provider%
|
||||
(init-field file tag-source)
|
||||
|
||||
(define image-names
|
||||
'("cover.jpg" "cover.png" "folder.jpg" "folder.png"))
|
||||
|
||||
(define/private (image-from-directory)
|
||||
(and file
|
||||
(let ((directory (path-only file)))
|
||||
(for/first ((image-name (in-list image-names))
|
||||
#:when
|
||||
(file-exists?
|
||||
(build-path directory image-name)))
|
||||
(build-path directory image-name)))))
|
||||
|
||||
(define/override (has-image?)
|
||||
(let ((tags (send tag-source get-tags)))
|
||||
(or (and tags
|
||||
(tags-valid? tags)
|
||||
(not (eq? (tags-picture->ext tags) #f)))
|
||||
(not (eq? (image-from-directory) #f)))))
|
||||
|
||||
(define/override (image->file target-file)
|
||||
(let* ((target (format "~a" target-file))
|
||||
(tags (send tag-source get-tags))
|
||||
(picture-extension
|
||||
(and tags
|
||||
(tags-valid? tags)
|
||||
(tags-picture->ext tags))))
|
||||
(if picture-extension
|
||||
(let ((stored-file
|
||||
(string-append
|
||||
target
|
||||
"."
|
||||
(symbol->string picture-extension))))
|
||||
(and (tags-picture->file tags stored-file)
|
||||
stored-file))
|
||||
(let ((source-file (image-from-directory)))
|
||||
(and source-file
|
||||
(let ((stored-file
|
||||
(string-append
|
||||
target
|
||||
(bytes->string/utf-8
|
||||
(path-get-extension source-file)))))
|
||||
(copy-file source-file
|
||||
stored-file
|
||||
#:exists-ok? #t)
|
||||
(format "~a" stored-file)))))))
|
||||
|
||||
(define/override (image->mimetype)
|
||||
(let ((tags (send tag-source get-tags)))
|
||||
(if (and tags
|
||||
(tags-valid? tags)
|
||||
(not (eq? (tags-picture->ext tags) #f)))
|
||||
(tags-picture->mimetype tags)
|
||||
(let ((source-file (image-from-directory)))
|
||||
(if source-file
|
||||
(case (string->symbol
|
||||
(string-downcase
|
||||
(bytes->string/utf-8
|
||||
(path-get-extension source-file))))
|
||||
((|.jpg| |.jpeg|) "image/jpeg")
|
||||
((|.png|) "image/png")
|
||||
(else 'no-mimetype))
|
||||
'no-mimetype)))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define booklet-provider-filesystem%
|
||||
(class booklet-provider%
|
||||
(init-field file)
|
||||
|
||||
(define/override (booklet-file)
|
||||
(and file
|
||||
(build-path (path-only file)
|
||||
"booklet.pdf")))
|
||||
|
||||
(define/override (has-booklet?)
|
||||
(let ((booklet (send this booklet-file)))
|
||||
(and booklet
|
||||
(file-exists? booklet))))
|
||||
|
||||
(super-new)))
|
||||
@@ -0,0 +1,116 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket-mimetypes/mimetypes
|
||||
racket/class
|
||||
racket/file
|
||||
racket/path
|
||||
"library-ref.rkt"
|
||||
"base/media-resource.rkt"
|
||||
"track-filesystem-providers.rkt"
|
||||
"track-tag-data.rkt"
|
||||
"base/track.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide track-filesystem%)
|
||||
|
||||
(define track-filesystem%
|
||||
(class track%
|
||||
(init-field library relative-path)
|
||||
|
||||
(check/c track-filesystem%
|
||||
relative-path
|
||||
list?)
|
||||
|
||||
(define file
|
||||
(send library resolve-path relative-path))
|
||||
|
||||
(define mime-type
|
||||
(mimetype-for-ext
|
||||
file
|
||||
#:default "application/octet-stream"))
|
||||
|
||||
(define tag-source
|
||||
(new tag-source-filesystem%
|
||||
[file file]))
|
||||
|
||||
(super-new
|
||||
[resource
|
||||
(new media-resource-file%
|
||||
[file file]
|
||||
[mime-type mime-type])]
|
||||
[music-library-factory-id
|
||||
(let ((cfg (send library get-cfg)))
|
||||
(library-ref
|
||||
(send cfg get-id)
|
||||
(send cfg get-kind)
|
||||
(send cfg get-kind-version)))]
|
||||
[track-factory-id 'file]
|
||||
[track-relive-info relative-path]
|
||||
[tag-data-provider
|
||||
(new tag-data-provider-filesystem%
|
||||
[tag-source tag-source]
|
||||
[fallback-data
|
||||
(track-tag-data
|
||||
(path->string
|
||||
(file-name-from-path file))
|
||||
""
|
||||
""
|
||||
0
|
||||
0)])]
|
||||
[image-provider
|
||||
(new image-provider-filesystem%
|
||||
[file file]
|
||||
[tag-source tag-source])]
|
||||
[booklet-provider
|
||||
(new booklet-provider-filesystem%
|
||||
[file file])])))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define file
|
||||
(make-temporary-file "rktplayer-track-~a.mp3"))
|
||||
|
||||
(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)
|
||||
file)
|
||||
(define/public (get-cfg)
|
||||
(new cfg%))
|
||||
(super-new)))
|
||||
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let* ((track
|
||||
(new track-filesystem%
|
||||
[library (new library%)]
|
||||
[relative-path
|
||||
(list (file-name-from-path file))]))
|
||||
(resource (send track get-resource))
|
||||
(library-reference
|
||||
(send track get-music-library-factory-id)))
|
||||
(check-true (is-a? track track%))
|
||||
(check-equal?
|
||||
(send resource get-file)
|
||||
(normal-case-path
|
||||
(path->complete-path file)))
|
||||
(check-equal? (send track get-track-factory-id) 'file)
|
||||
(check-equal? (send track get-track-relive-info)
|
||||
(list (file-name-from-path file)))
|
||||
(check-true (is-a? resource media-resource-file%))
|
||||
(check-true (send resource is-seekable?))
|
||||
(check-equal? (send resource get-mime-type)
|
||||
"audio/mpeg")
|
||||
(check-equal? (library-ref-library-id library-reference)
|
||||
'test-library)))
|
||||
(lambda ()
|
||||
(when (file-exists? file)
|
||||
(delete-file file)))))
|
||||
@@ -0,0 +1,191 @@
|
||||
#lang racket/base
|
||||
|
||||
(require net/url
|
||||
racket-mimetypes/mimetypes
|
||||
racket/class
|
||||
racket/list
|
||||
racket/port
|
||||
racket/string
|
||||
(prefix-in upnp: racket-upnp)
|
||||
"base/booklet-provider.rkt"
|
||||
"base/image-provider.rkt"
|
||||
"library-ref.rkt"
|
||||
"base/media-resource.rkt"
|
||||
"base/tag-data-provider.rkt"
|
||||
"track-tag-data.rkt"
|
||||
"base/track.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide track-media-server%)
|
||||
|
||||
(define tag-data-provider-media-server%
|
||||
(class tag-data-provider%
|
||||
(init-field
|
||||
entry
|
||||
resource)
|
||||
|
||||
(define/override (get-tag-data)
|
||||
(let ((artists
|
||||
(upnp:media-item-artists entry)))
|
||||
(track-tag-data
|
||||
(upnp:media-entry-title entry)
|
||||
(cond
|
||||
((not (null? artists))
|
||||
(car artists))
|
||||
((upnp:media-item-creator entry)
|
||||
(upnp:media-item-creator entry))
|
||||
(else ""))
|
||||
(or (upnp:media-item-album entry)
|
||||
"")
|
||||
(or
|
||||
(upnp:media-item-original-track-number
|
||||
entry)
|
||||
0)
|
||||
(or (upnp:media-resource-duration
|
||||
resource)
|
||||
0))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define image-provider-media-server%
|
||||
(class image-provider%
|
||||
(init-field uri)
|
||||
|
||||
(define mime-type
|
||||
(and uri
|
||||
(mimetype-for-ext
|
||||
(regexp-replace
|
||||
#px"[?#].*$"
|
||||
uri
|
||||
"")
|
||||
#:default
|
||||
"application/octet-stream")))
|
||||
|
||||
(define/private (stored-file target-file)
|
||||
(let ((extension
|
||||
(cond
|
||||
((equal? mime-type "image/jpeg") ".jpg")
|
||||
((equal? mime-type "image/png") ".png")
|
||||
(else ""))))
|
||||
(string-append
|
||||
(format "~a" target-file)
|
||||
extension)))
|
||||
|
||||
(define/override (has-image?)
|
||||
(and (string? uri)
|
||||
(not (string=? uri ""))))
|
||||
|
||||
(define/override (image->file target-file)
|
||||
(and
|
||||
(send this has-image?)
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(lambda (exception)
|
||||
(warn-rktplayer
|
||||
"Could not retrieve media-server image: ~a"
|
||||
(exn-message exception))
|
||||
#f)))
|
||||
(let ((file (stored-file target-file)))
|
||||
(call/input-url
|
||||
(string->url uri)
|
||||
get-pure-port
|
||||
(lambda (input)
|
||||
(call-with-output-file
|
||||
file
|
||||
(lambda (output)
|
||||
(copy-port input output))
|
||||
#:exists 'replace)))
|
||||
file))))
|
||||
|
||||
(define/override (image->mimetype)
|
||||
(or mime-type
|
||||
'no-mimetype))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define booklet-provider-media-server%
|
||||
(class booklet-provider%
|
||||
(define/override (has-booklet?)
|
||||
#f)
|
||||
|
||||
(define/override (booklet-file)
|
||||
#f)
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define (audio-resource? resource)
|
||||
(let ((content-type
|
||||
(upnp:media-resource-content-type
|
||||
resource)))
|
||||
(and content-type
|
||||
(string-prefix?
|
||||
content-type
|
||||
"audio/"))))
|
||||
|
||||
(define (resource-seekable? resource)
|
||||
(let ((protocol-info
|
||||
(upnp:media-resource-protocol-info
|
||||
resource)))
|
||||
(and protocol-info
|
||||
(regexp-match?
|
||||
#px"DLNA[.]ORG_OP=(?:01|10|11)"
|
||||
protocol-info))))
|
||||
|
||||
(define track-media-server%
|
||||
(class track%
|
||||
(init-field
|
||||
library
|
||||
entry)
|
||||
|
||||
(check/c track-media-server%
|
||||
entry
|
||||
upnp:media-item?)
|
||||
|
||||
(define source-resource
|
||||
(or
|
||||
(findf
|
||||
audio-resource?
|
||||
(upnp:media-item-resources entry))
|
||||
(car
|
||||
(upnp:media-item-resources entry))))
|
||||
|
||||
(define resource
|
||||
(new media-resource%
|
||||
[uri
|
||||
(upnp:media-resource-uri
|
||||
source-resource)]
|
||||
[mime-type
|
||||
(upnp:media-resource-content-type
|
||||
source-resource)]
|
||||
[protocol-info
|
||||
(upnp:media-resource-protocol-info
|
||||
source-resource)]
|
||||
[seekable?
|
||||
(resource-seekable?
|
||||
source-resource)]))
|
||||
|
||||
(super-new
|
||||
[resource resource]
|
||||
[music-library-factory-id
|
||||
(let ((cfg (send library get-cfg)))
|
||||
(library-ref
|
||||
(send cfg get-id)
|
||||
(send cfg get-kind)
|
||||
(send cfg get-kind-version)))]
|
||||
[track-factory-id
|
||||
'media-server-item]
|
||||
[track-relive-info
|
||||
(list
|
||||
(upnp:media-entry-parent-id entry)
|
||||
(upnp:media-entry-id entry))]
|
||||
[tag-data-provider
|
||||
(new tag-data-provider-media-server%
|
||||
[entry entry]
|
||||
[resource source-resource])]
|
||||
[image-provider
|
||||
(new image-provider-media-server%
|
||||
[uri
|
||||
(upnp:media-item-album-art-uri
|
||||
entry)])]
|
||||
[booklet-provider
|
||||
(new booklet-provider-media-server%)])))
|
||||
@@ -0,0 +1,175 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket/match
|
||||
"library-factory.rkt"
|
||||
"library-ref.rkt"
|
||||
"base/track.rkt"
|
||||
"../misc/utils.rkt")
|
||||
|
||||
(provide track-store?
|
||||
track-store-id
|
||||
track-store-number
|
||||
track-store-title
|
||||
track->store
|
||||
store->track)
|
||||
|
||||
(define track-store-version
|
||||
1)
|
||||
|
||||
(define (track-store? stored)
|
||||
(match stored
|
||||
((list 'track
|
||||
(== track-store-version)
|
||||
_
|
||||
number
|
||||
title
|
||||
library-reference
|
||||
track-factory-id
|
||||
_)
|
||||
(and (exact-integer? number)
|
||||
(string? title)
|
||||
(library-ref? library-reference)
|
||||
(symbol? track-factory-id)))
|
||||
(else #f)))
|
||||
|
||||
(define (track-store-id stored)
|
||||
(check/c track-store-id stored track-store?)
|
||||
(list-ref stored 2))
|
||||
|
||||
(define (track-store-number stored)
|
||||
(check/c track-store-number stored track-store?)
|
||||
(list-ref stored 3))
|
||||
|
||||
(define (track-store-title stored)
|
||||
(check/c track-store-title stored track-store?)
|
||||
(list-ref stored 4))
|
||||
|
||||
(define (track->store track)
|
||||
(check/c track->store track (is-a?/c track<%>))
|
||||
|
||||
(let ((stored
|
||||
(list 'track
|
||||
track-store-version
|
||||
(send track get-id)
|
||||
(send track get-number)
|
||||
(send track get-title)
|
||||
(send track get-music-library-factory-id)
|
||||
(send track get-track-factory-id)
|
||||
(send track get-track-relive-info))))
|
||||
(check/c track->store stored track-store?)
|
||||
stored))
|
||||
|
||||
(define (store->track stored factory)
|
||||
(check/c store->track
|
||||
factory
|
||||
(is-a?/c library-factory%))
|
||||
|
||||
(and
|
||||
(track-store? stored)
|
||||
(with-handlers ((exn:fail?
|
||||
(lambda (_)
|
||||
#f)))
|
||||
(let* ((library-reference (list-ref stored 5))
|
||||
(library
|
||||
(send factory
|
||||
get-library
|
||||
(library-ref-library-id library-reference)
|
||||
(library-ref-kind library-reference)
|
||||
(library-ref-version library-reference)))
|
||||
(root-container
|
||||
(send library get-root-container))
|
||||
(track-reliver
|
||||
(send root-container get-track-reliver))
|
||||
(track
|
||||
(track-reliver
|
||||
(list-ref stored 6)
|
||||
(list-ref stored 7))))
|
||||
(and (object? track)
|
||||
(is-a? track track<%>)
|
||||
track)))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit
|
||||
racket/file
|
||||
"libraries-config.rkt"
|
||||
"library-filesystem.rkt"
|
||||
"library-item.rkt")
|
||||
|
||||
(define settings%
|
||||
(class object%
|
||||
(define values
|
||||
(make-hash))
|
||||
|
||||
(define/public (clone _)
|
||||
this)
|
||||
|
||||
(define/public (get key default)
|
||||
(hash-ref values key default))
|
||||
|
||||
(define/public (set! key value)
|
||||
(hash-set! values key value))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define root
|
||||
(make-temporary-file
|
||||
"rktplayer-track-store-~a"
|
||||
'directory))
|
||||
|
||||
(define file-name
|
||||
"track.mp3")
|
||||
|
||||
(define file
|
||||
(build-path root file-name))
|
||||
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(call-with-output-file file void))
|
||||
(lambda ()
|
||||
(let* ((libraries-config
|
||||
(new libraries-config%
|
||||
[settings (new settings%)]))
|
||||
(factory
|
||||
(new library-factory%
|
||||
[libraries-config libraries-config])))
|
||||
(send libraries-config
|
||||
add-library
|
||||
(library-item
|
||||
'test-library
|
||||
"Test library"
|
||||
'filesystem
|
||||
1
|
||||
root
|
||||
#f
|
||||
100
|
||||
#t))
|
||||
(register-library-filesystem! factory)
|
||||
|
||||
(let* ((library
|
||||
(send factory
|
||||
get-library
|
||||
'test-library
|
||||
'filesystem
|
||||
1))
|
||||
(track
|
||||
(send library
|
||||
make-track
|
||||
(list (string->path file-name))))
|
||||
(stored (track->store track))
|
||||
(relived (store->track stored factory)))
|
||||
(check-true (track-store? stored))
|
||||
(check-equal? (track-store-id stored)
|
||||
(send track get-id))
|
||||
(check-equal? (track-store-number stored)
|
||||
(send track get-number))
|
||||
(check-equal? (track-store-title stored)
|
||||
(send track get-title))
|
||||
(check-true (is-a? relived track<%>))
|
||||
(check-equal?
|
||||
(normal-case-path
|
||||
(send (send relived get-resource)
|
||||
get-file))
|
||||
(normal-case-path file)))))
|
||||
(lambda ()
|
||||
(delete-directory/files root))))
|
||||
@@ -0,0 +1,7 @@
|
||||
#lang racket/base
|
||||
|
||||
(provide (struct-out track-tag-data))
|
||||
|
||||
(struct track-tag-data
|
||||
(title artist album number length)
|
||||
#:prefab)
|
||||
+86
-10
@@ -1,6 +1,7 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/gui
|
||||
racket/contract
|
||||
xml
|
||||
xml/xexpr
|
||||
simple-log
|
||||
@@ -12,7 +13,6 @@
|
||||
simple-row-formatter
|
||||
while
|
||||
open-file-manager
|
||||
basedir
|
||||
dbg-rktplayer
|
||||
err-rktplayer
|
||||
info-rktplayer
|
||||
@@ -24,11 +24,59 @@
|
||||
path-equal?
|
||||
make-select-list
|
||||
new-id
|
||||
check/c
|
||||
check/c*
|
||||
(all-from-out racket/contract)
|
||||
)
|
||||
|
||||
|
||||
(sl-def-log rktplayer)
|
||||
|
||||
(define-syntax check/c
|
||||
(syntax-rules ()
|
||||
((_ for-cl for-func name contract-expr)
|
||||
(unless (contract-first-order-passes? contract-expr name)
|
||||
(raise-argument-error
|
||||
(string->symbol (format "~a:~a" 'for-cl 'for-func))
|
||||
(format "~s" 'contract-expr)
|
||||
name)))
|
||||
((_ for-cl name contract-expr)
|
||||
(unless (contract-first-order-passes? contract-expr name)
|
||||
(raise-argument-error
|
||||
'for-cl
|
||||
(format "~s" 'contract-expr)
|
||||
name)))
|
||||
((_ name contract-expr)
|
||||
(unless (contract-first-order-passes? contract-expr name)
|
||||
(error
|
||||
(format "~a: expected ~a, got ~a"
|
||||
'name
|
||||
'contract-expr
|
||||
name))))))
|
||||
|
||||
(define-syntax check/c*-internal
|
||||
(syntax-rules ()
|
||||
((_ for-cl (for-func name type?))
|
||||
(check/c for-cl for-func name type?))
|
||||
((_ for-cl (name type?))
|
||||
(check/c for-cl name type?))))
|
||||
|
||||
(define-syntax check/c*-internal-func
|
||||
(syntax-rules ()
|
||||
((_ for-cl for-func (name type?))
|
||||
(check/c for-cl for-func name type?))))
|
||||
|
||||
(define-syntax check/c*
|
||||
(syntax-rules ()
|
||||
((_ (for-cl for-func) check ...)
|
||||
(begin
|
||||
(check/c*-internal-func for-cl for-func check)
|
||||
...))
|
||||
((_ for-cl check ...)
|
||||
(begin
|
||||
(check/c*-internal for-cl check)
|
||||
...))))
|
||||
|
||||
(define-syntax while
|
||||
(syntax-rules ()
|
||||
((_ cond body ...)
|
||||
@@ -114,15 +162,6 @@
|
||||
[else (do-open "xdg-open" folder)]))
|
||||
)
|
||||
|
||||
(define (basedir file)
|
||||
(if (string? file)
|
||||
(basedir (string->path file))
|
||||
(if (or (eq? (file-or-directory-type file) 'file)
|
||||
(eq? (file-or-directory-type file) 'link))
|
||||
(call-with-values (λ () (split-path file))
|
||||
(λ (dir file d) dir))
|
||||
file)))
|
||||
|
||||
(define (path-equal? p1 p2)
|
||||
(let ((p1* (build-path p1))
|
||||
(p2* (build-path p2))
|
||||
@@ -169,4 +208,41 @@
|
||||
(id (string->symbol (format "id-~a-~a" s r))))
|
||||
id))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define (multiply a b c)
|
||||
(check/c* (my-class multiply)
|
||||
(a number?)
|
||||
(b number?)
|
||||
(c symbol?))
|
||||
(format "symbol ~a = ~a" c (* a b)))
|
||||
|
||||
(check-equal? (multiply 2 3 'answer)
|
||||
"symbol answer = 6")
|
||||
|
||||
(check-not-exn
|
||||
(lambda ()
|
||||
(define value 1)
|
||||
(check/c my-class value number?)))
|
||||
|
||||
(check-exn
|
||||
exn:fail:contract?
|
||||
(lambda ()
|
||||
(multiply 2 "3" 'answer)))
|
||||
|
||||
(check-exn
|
||||
#rx"my-class:multiply"
|
||||
(lambda ()
|
||||
(multiply 2 3 "answer")))
|
||||
|
||||
(check-not-exn
|
||||
(lambda ()
|
||||
(define value "root")
|
||||
(check/c value (or/c path? string?))))
|
||||
|
||||
(check-exn
|
||||
#rx"or/c"
|
||||
(lambda ()
|
||||
(define value 42)
|
||||
(check/c my-class value (or/c path? string?)))))
|
||||
@@ -1,53 +0,0 @@
|
||||
#lang racket
|
||||
|
||||
(require racket-audio)
|
||||
|
||||
(provide music-lib-relevant?
|
||||
is-music-dir?
|
||||
is-music-file?
|
||||
basename
|
||||
library-formatter
|
||||
)
|
||||
|
||||
(define (music-lib-relevant? f)
|
||||
(let ((type (file-or-directory-type f #t)))
|
||||
(if (eq? type 'directory)
|
||||
(let ((name (basename f)))
|
||||
(not (string-prefix? name ".")))
|
||||
(if (eq? type 'file)
|
||||
(let* ((fn (string-downcase (format "~a" f)))
|
||||
(exts (audio-known-exts?)))
|
||||
(let ((l (filter (λ (e) (string-suffix? fn (string-append "." e))) exts)))
|
||||
(not (null? l))))
|
||||
#f))))
|
||||
|
||||
(define (is-music-dir? f)
|
||||
(and (music-lib-relevant? f)
|
||||
(directory-exists? f)))
|
||||
|
||||
(define (is-music-file? f)
|
||||
(and (music-lib-relevant? f)
|
||||
(file-exists? f)))
|
||||
|
||||
(define (basename file)
|
||||
(call-with-values (λ () (split-path file))
|
||||
(λ (base name is-dir)
|
||||
(path->string name))))
|
||||
|
||||
(define (library-formatter row)
|
||||
(let* ((file-entry (car row))
|
||||
(file-id (format "file-~a" (cadr row)))
|
||||
(the-file (string-replace
|
||||
(if (equal? file-id "lib-up") ".." (format "~a" file-entry))
|
||||
"\\" "/"))
|
||||
)
|
||||
;(displayln row)
|
||||
(list (list 'td (list (list 'class "library-entry") (list 'id file-id) (list 'file (format "~a" the-file)))
|
||||
(if (equal? file-id "lib-up")
|
||||
file-entry
|
||||
(basename file-entry))
|
||||
))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
@@ -2,7 +2,8 @@
|
||||
|
||||
(require racket/class
|
||||
racket-audio
|
||||
"utils.rkt"
|
||||
"../../misc/utils.rkt"
|
||||
"../../library/base/media-resource.rkt"
|
||||
lru-cache
|
||||
)
|
||||
|
||||
@@ -114,11 +115,23 @@
|
||||
|
||||
(define/public (get-volume)
|
||||
(check-player)
|
||||
(audio-volume player))
|
||||
(* 100.0
|
||||
(sqrt
|
||||
(/ (min 100.0
|
||||
(max 0.0
|
||||
(audio-volume player)))
|
||||
100.0))))
|
||||
|
||||
(define/public (set-volume! percentage)
|
||||
(check-player)
|
||||
(audio-volume! player percentage))
|
||||
(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.
|
||||
@@ -138,14 +151,25 @@
|
||||
|
||||
(define/public (play playlist*)
|
||||
(send this playlist! playlist*)
|
||||
(send this play-track 0))
|
||||
(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)))
|
||||
(let ((id (audio-play! player (send track get-file))))
|
||||
(register-music-id&track-nr id 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)
|
||||
@@ -154,21 +178,18 @@
|
||||
(let ((track-nr (music-id->track-nr music-id)))
|
||||
(if (eq? track-nr #f)
|
||||
(error "Unexpected: no track-nr for given music-id")
|
||||
(begin
|
||||
(cond
|
||||
((eq? repeat 'repeat-one) (play-track track-nr))
|
||||
((eq? repeat 'repeat-all)
|
||||
(set! track-nr (+ track-nr 1))
|
||||
(when (>= track-nr (send playlist length))
|
||||
(set! track-nr 0))
|
||||
(play-track track-nr))
|
||||
(else
|
||||
(set! track-nr (+ track-nr 1))
|
||||
(if (>= track-nr (send playlist length))
|
||||
(stop)
|
||||
(play-track track-nr)))
|
||||
)
|
||||
)
|
||||
(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))))
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -181,20 +202,17 @@
|
||||
(let ((track-nr (music-id->track-nr music-id)))
|
||||
(if (eq? track-nr #f)
|
||||
(error "Unexpected: no track-nr for given music-id")
|
||||
(begin
|
||||
(cond
|
||||
((eq? repeat 'repeat-one) (play-track track-nr))
|
||||
((eq? repeat 'repeat-all)
|
||||
(set! track-nr (- track-nr 1))
|
||||
(when (< track-nr 0)
|
||||
(set! track-nr (- (send playlist length) 1)))
|
||||
(play-track track-nr))
|
||||
(else
|
||||
(set! track-nr (- track-nr 1))
|
||||
(when (< track-nr 0) (set! track-nr 0))
|
||||
(play-track track-nr))
|
||||
)
|
||||
)
|
||||
(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))))
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -215,8 +233,8 @@
|
||||
(send this play!)))
|
||||
|
||||
(define/public (stop)
|
||||
(check-player)
|
||||
(audio-stop! player))
|
||||
(unless (eq? player #f)
|
||||
(audio-stop! player)))
|
||||
|
||||
(define/public (seek percentage)
|
||||
(check-player)
|
||||
@@ -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])))
|
||||
-438
@@ -1,438 +0,0 @@
|
||||
#lang racket
|
||||
|
||||
(require racket/class
|
||||
"music-library.rkt"
|
||||
racket-audio
|
||||
"utils.rkt"
|
||||
racket-sprintf
|
||||
keystore/class
|
||||
racket/list
|
||||
)
|
||||
|
||||
(provide track%
|
||||
playlist%
|
||||
)
|
||||
|
||||
(define the-displayln displayln)
|
||||
(define list-for-each for-each)
|
||||
(define list-length length)
|
||||
|
||||
(define next-track-id 0)
|
||||
|
||||
(define track%
|
||||
(class object%
|
||||
(init-field
|
||||
[file #f]
|
||||
[title ""]
|
||||
[artist ""]
|
||||
[album ""]
|
||||
[length 0]
|
||||
[number 0]
|
||||
)
|
||||
|
||||
(define/public (displayln)
|
||||
(the-displayln (format "~a - ~a - ~a - ~a"
|
||||
number
|
||||
title
|
||||
album
|
||||
length)))
|
||||
|
||||
(define my-id (begin
|
||||
(set! next-track-id (+ next-track-id 1))
|
||||
(when (> next-track-id 10000000)
|
||||
(set! next-track-id 1))
|
||||
next-track-id))
|
||||
|
||||
(define/public (get-file) file)
|
||||
(define/public (get-title) title)
|
||||
(define/public (get-artist) artist)
|
||||
(define/public (get-album) album)
|
||||
(define/public (get-number) number)
|
||||
(define/public (get-length) length)
|
||||
(define/public (get-id) my-id)
|
||||
|
||||
(define/public (booklet-file)
|
||||
(let* ((dir (path-only file))
|
||||
(booklet-file (build-path dir "booklet.pdf")))
|
||||
booklet-file))
|
||||
|
||||
(define/public (has-booklet?)
|
||||
(file-exists? (send this booklet-file)))
|
||||
|
||||
(define/public (track< t2)
|
||||
(if (string-ci<? album (send t2 get-album))
|
||||
#t
|
||||
(if (string-ci=? album (send t2 get-album))
|
||||
(< number (send t2 get-number))
|
||||
#f))
|
||||
)
|
||||
|
||||
(define (read-tags)
|
||||
(let* ((f (if (path? file) (path->string file) file))
|
||||
(tags (id3-tags f))
|
||||
(tmpfile #f))
|
||||
(unless (tags-valid? tags)
|
||||
(let ((nfile (make-temporary-file "rktplayer-~a" #:copy-from f)))
|
||||
(set! tags (id3-tags nfile))
|
||||
(set! tmpfile nfile)
|
||||
))
|
||||
(unless (eq? tmpfile #f)
|
||||
(delete-file tmpfile))
|
||||
tags
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (image->file* to-file)
|
||||
#f)
|
||||
|
||||
(define/public (image->file to-file*)
|
||||
(let ((to-file (format "~a" to-file*))
|
||||
(tags (read-tags)))
|
||||
(dbg-rktplayer "image->file ~a" to-file)
|
||||
(let ((image-from-tags (λ ()
|
||||
(if (tags-valid? tags)
|
||||
(let ((ext (tags-picture->ext tags)))
|
||||
(if (eq? ext #f)
|
||||
#f
|
||||
(let ((path (string-append to-file "." (symbol->string ext))))
|
||||
(if (tags-picture->file tags path)
|
||||
path
|
||||
#f)
|
||||
)
|
||||
)
|
||||
)
|
||||
#f)
|
||||
)
|
||||
)
|
||||
)
|
||||
(let ((path (image-from-tags)))
|
||||
(dbg-rktplayer "image-from-tags: ~a" path)
|
||||
(if (eq? path #f)
|
||||
(let* ((bd (basedir file))
|
||||
(files (filter
|
||||
(λ (f)
|
||||
(let ((file (build-path bd f)))
|
||||
(file-exists? file)))
|
||||
(list "cover.jpg" "cover.png" "folder.jpg" "folder.png"))))
|
||||
(if (null? files)
|
||||
#f
|
||||
(let ((file (string-append to-file (bytes->string/utf-8 (path-get-extension (car files))))))
|
||||
(copy-file (build-path bd (car files)) file #:exists-ok? #t)
|
||||
(dbg-rktplayer "image from basedir: ~a" file)
|
||||
(format "~a" file))
|
||||
))
|
||||
path))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (image->mimetype*)
|
||||
#f)
|
||||
|
||||
(define/public (image->mimetype)
|
||||
(let ((tags (read-tags)))
|
||||
(if (tags-valid? tags)
|
||||
(tags-picture->mimetype tags)
|
||||
'no-mimetype)))
|
||||
|
||||
(super-new)
|
||||
|
||||
(begin
|
||||
(let ((use-tags #t))
|
||||
(if use-tags
|
||||
(unless (eq? file #f)
|
||||
(let ((tags (read-tags)))
|
||||
(if (tags-valid? tags)
|
||||
(begin
|
||||
(set! title (tags-title tags))
|
||||
(set! artist (tags-artist tags))
|
||||
(set! album (tags-album tags))
|
||||
(set! number (tags-track tags))
|
||||
(set! length (tags-length tags))
|
||||
)
|
||||
(begin
|
||||
(set! title "invalid tags")
|
||||
(set! artist "invalid tags")
|
||||
(set! album "invalid tags")
|
||||
(set! number number)
|
||||
(set! length -1)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(unless (eq? file #f)
|
||||
(set! title (format "~a" file))
|
||||
(set! number 0))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define list-len length)
|
||||
(define orig-for-each for-each)
|
||||
|
||||
(define playlist%
|
||||
(class object%
|
||||
(init-field
|
||||
[start-map #f]
|
||||
[max-tracks 100]
|
||||
[name "Default"]
|
||||
[id #f]
|
||||
[settings #f]
|
||||
)
|
||||
|
||||
(define store (new keystore% [file 'rktplayer]))
|
||||
(define tracks '())
|
||||
|
||||
(define (can-add? file)
|
||||
(and (<= (list-len tracks) max-tracks)
|
||||
(is-music-file? file)))
|
||||
|
||||
(define (add-track* file)
|
||||
(let ((track (new track% [file file])))
|
||||
(set! tracks (append tracks (list track)))))
|
||||
|
||||
(define (read-tracks-internal dir)
|
||||
;(displayln (format "dir = ~a" dir))
|
||||
(if (> (list-len tracks) max-tracks)
|
||||
'done
|
||||
(if (file-exists? dir)
|
||||
(when (can-add? dir)
|
||||
(add-track dir))
|
||||
(if (directory-exists? dir)
|
||||
(let ((content (directory-list dir)))
|
||||
(orig-for-each (λ (entry)
|
||||
(let ((p (build-path dir entry)))
|
||||
(if (directory-exists? p)
|
||||
(read-tracks-internal p)
|
||||
(when (and (file-exists? p) (can-add? p))
|
||||
;(displayln (format "Adding ~a" p))
|
||||
(add-track* p)))))
|
||||
content))
|
||||
'no-file-or-dir
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
;(define/public (set-name! n)
|
||||
; (set! name n))
|
||||
|
||||
;(define/public (set-id! id*)
|
||||
; (set! id id*))
|
||||
|
||||
;(define/public (get-id)
|
||||
; id)
|
||||
|
||||
;(define/public (get-name)
|
||||
; name)
|
||||
|
||||
(define/public (tabs)
|
||||
(map (λ (k)
|
||||
(if (string? k)
|
||||
(string->symbol k)
|
||||
k))
|
||||
(send store get 'tabs '(tabkey-default)))
|
||||
)
|
||||
|
||||
(define/public (tab-count)
|
||||
(list-length (tabs)))
|
||||
|
||||
(define/public (make-tab-key)
|
||||
(string->symbol
|
||||
(format "tabkey-~a-~a" (current-milliseconds) (random 10000))))
|
||||
|
||||
(define/public (get-tab-name idx)
|
||||
(let* ((t (tabs))
|
||||
(entry (list-ref t idx)))
|
||||
(let ((v (send store get entry (list (format "Playlist-~a" idx) '()))))
|
||||
(car v))))
|
||||
|
||||
(define/public (set-tab-name! idx name)
|
||||
(let* ((t (tabs))
|
||||
(entry (list-ref t idx))
|
||||
(v (send store get entry (list (format "Playlist-~a" idx) '())))
|
||||
)
|
||||
(send store set! entry (list name (cadr v)))
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (tab-id idx)
|
||||
(let ((t (tabs)))
|
||||
(list-ref t idx)))
|
||||
|
||||
(define/public (tab-index id)
|
||||
(let ((t (tabs)))
|
||||
(letrec ((f (λ (t idx)
|
||||
(if (null? t)
|
||||
#f
|
||||
(if (eq? (car t) id)
|
||||
idx
|
||||
(f (cdr t) (+ idx 1)))))))
|
||||
(f t 0))))
|
||||
|
||||
(define/public (drop-tab! idx)
|
||||
(let* ((t (tabs))
|
||||
(entry (list-ref t idx))
|
||||
)
|
||||
(send store set! 'tabs (list-drop! t idx))
|
||||
(send store drop! entry)
|
||||
))
|
||||
|
||||
(define/public (add-tab!)
|
||||
(let* ((t (tabs))
|
||||
(new-entry (send this make-tab-key)))
|
||||
(send store set! 'tabs (append t (list new-entry)))
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (save-tab!)
|
||||
(let* ((entry id)
|
||||
(idx (send this tab-index entry))
|
||||
)
|
||||
(dbg-rktplayer "entry id = ~a, ~a" entry idx)
|
||||
(if (eq? idx #f)
|
||||
(err-rktplayer "Cannot get tab for id ~a" entry)
|
||||
(let ((value (list (send this get-tab-name idx)
|
||||
(map (λ (track)
|
||||
(send track get-file))
|
||||
tracks))))
|
||||
(send store set! entry value)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (load-tab idx)
|
||||
(let* ((t (tabs))
|
||||
(entry (list-ref t idx))
|
||||
)
|
||||
(dbg-rktplayer "loading ~a" entry)
|
||||
(set! id entry)
|
||||
(set! tracks '())
|
||||
(let ((value (send store get entry (list "Default" '()))))
|
||||
(set! name (car value))
|
||||
(list-for-each (λ (file)
|
||||
(when (file-exists? file)
|
||||
(send this add-track file #f)))
|
||||
(cadr value))
|
||||
)
|
||||
)
|
||||
#t
|
||||
)
|
||||
|
||||
(define/public (read-tracks)
|
||||
(set! tracks '())
|
||||
(read-tracks-internal start-map)
|
||||
(set! tracks
|
||||
(sort tracks (λ (t1 t2)
|
||||
(send t1 track< t2))))
|
||||
(send this save-tab!)
|
||||
)
|
||||
|
||||
(define/public (length)
|
||||
(list-len tracks))
|
||||
|
||||
(define/public (add-track file . args)
|
||||
(add-track* file)
|
||||
(when (null? args)
|
||||
(send this save-tab!))
|
||||
)
|
||||
|
||||
(define/public (move-track from-idx to-idx)
|
||||
(let ((tr (list-ref tracks from-idx))
|
||||
(idx 0))
|
||||
(if (= from-idx to-idx)
|
||||
#t
|
||||
(begin
|
||||
(when (< from-idx to-idx)
|
||||
(set! to-idx (- to-idx 1)))
|
||||
(let* ((l1 (if (= from-idx 0)
|
||||
'()
|
||||
(take tracks from-idx)))
|
||||
(l2 (drop tracks (+ from-idx 1)))
|
||||
(l (append l1 l2))
|
||||
)
|
||||
(set! tracks (append
|
||||
(if (= to-idx 0) '() (take l to-idx))
|
||||
(list tr)
|
||||
(drop l to-idx)))
|
||||
)
|
||||
(send this save-tab!)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (drop-id track-id)
|
||||
(let ((idx (send this index track-id)))
|
||||
(let* ((l1 (if (= idx 0) '() (take tracks idx)))
|
||||
(l2 (drop tracks (+ idx 1)))
|
||||
(l (append l1 l2)))
|
||||
(set! tracks l)
|
||||
(send this save-tab!)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (track i)
|
||||
(list-ref tracks i))
|
||||
|
||||
(define/public (display-tracks)
|
||||
(orig-for-each (λ (track)
|
||||
(send track displayln))
|
||||
tracks))
|
||||
|
||||
(define/public (for-each f)
|
||||
(let ((idx 0))
|
||||
(orig-for-each (λ (track)
|
||||
(f idx track)
|
||||
(set! idx (+ idx 1)))
|
||||
tracks)
|
||||
)
|
||||
)
|
||||
|
||||
(define/public (track-id i)
|
||||
(string->symbol (format "track-~a" (+ i 1))))
|
||||
|
||||
(define/public (index id)
|
||||
(- (string->number (substring (symbol->string id) 6)) 1))
|
||||
|
||||
(define/public (to-html)
|
||||
(define (formatter row)
|
||||
(let* ((track-idx (car row))
|
||||
(track (track track-idx)))
|
||||
(list
|
||||
(list 'td (list (list 'class "number"))
|
||||
(format "~a." (send track get-number)))
|
||||
(list 'td (list (list 'class "title"))
|
||||
(send track get-title))
|
||||
(list 'td (list (list 'class "album"))
|
||||
(send track get-album))
|
||||
(list 'td (list (list 'class "length"))
|
||||
(let* ((length-s (send track get-length))
|
||||
(hour (quotient length-s 3600))
|
||||
(min (quotient (remainder length-s 3600) 60))
|
||||
(sec (remainder (remainder length-s 3600) 60)))
|
||||
(sprintf "%02d:%02d:%02d" hour min sec)))
|
||||
)))
|
||||
|
||||
(letrec ((f (λ (i N)
|
||||
(if (< i N)
|
||||
(cons (list (send this track-id i) i) (f (+ i 1) N))
|
||||
'()))))
|
||||
(dbg-rktplayer "Number of rows in playlist: ~a" (send this length))
|
||||
(let ((rows (f 0 (send this length))))
|
||||
(mktable rows 'tracks formatter))))
|
||||
|
||||
(super-new)
|
||||
|
||||
(begin
|
||||
(if (eq? start-map #f)
|
||||
(send this load-tab 0)
|
||||
(set! id (send this tab-id id)))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
+21
-7
@@ -1,20 +1,24 @@
|
||||
#lang racket
|
||||
|
||||
(require racket/gui
|
||||
"gui.rkt"
|
||||
"tray.rkt"
|
||||
"translate.rkt"
|
||||
"gui/gui.rkt"
|
||||
"gui/tray.rkt"
|
||||
"gui/translate.rkt"
|
||||
"library/libraries-config.rkt"
|
||||
"library/library-factory.rkt"
|
||||
"library/library-filesystem.rkt"
|
||||
"library/library-media-server.rkt"
|
||||
simple-ini/class
|
||||
racket-audio
|
||||
racket-webview
|
||||
racket/runtime-path
|
||||
"utils.rkt"
|
||||
"misc/utils.rkt"
|
||||
net/uri-codec
|
||||
)
|
||||
|
||||
(provide run)
|
||||
|
||||
(define-runtime-path rkt-gui-dir "gui")
|
||||
(define-runtime-path rkt-gui-dir "gui/html")
|
||||
|
||||
(define log-file (build-path (find-system-path 'cache-dir) ".rktplayer.log"))
|
||||
|
||||
@@ -63,10 +67,21 @@
|
||||
[ini ini]
|
||||
[file-getter my-file-getter]
|
||||
))
|
||||
(libraries-config
|
||||
(new libraries-config%
|
||||
[settings (send context settings 'settings)]))
|
||||
(library-factory
|
||||
(new library-factory%
|
||||
[libraries-config libraries-config]))
|
||||
)
|
||||
(set-library-factory! library-factory)
|
||||
(register-library-filesystem! library-factory)
|
||||
(register-library-media-server! library-factory)
|
||||
(displayln (format "ini file: ~a" (send ini get-file)))
|
||||
(set-lang! (send ini get 'settings 'language 'en))
|
||||
(let* ((window (new rktplayer% [wv-context context] [log-file log-file]))
|
||||
(let* ((window (new rktplayer%
|
||||
[wv-context context]
|
||||
[log-file log-file]))
|
||||
(tray (new rktplayer-tray% [rktplayer-gui window]))
|
||||
)
|
||||
(set! rktplayer-window window)
|
||||
@@ -117,4 +132,3 @@
|
||||
)
|
||||
|
||||
;(run)
|
||||
|
||||
|
||||
-274
@@ -1,274 +0,0 @@
|
||||
#lang racket
|
||||
|
||||
(require racket-webview
|
||||
racket/runtime-path
|
||||
racket/gui
|
||||
racket-sprintf
|
||||
open-app
|
||||
xml
|
||||
"utils.rkt"
|
||||
"music-library.rkt"
|
||||
"translate.rkt"
|
||||
"playlist.rkt"
|
||||
"player.rkt"
|
||||
"libraries.rkt"
|
||||
)
|
||||
|
||||
(provide
|
||||
(all-from-out racket-webview)
|
||||
settings%
|
||||
)
|
||||
|
||||
(define-runtime-path rkt-gui-dir "gui")
|
||||
|
||||
(define library-dlg%
|
||||
(class wv-dialog%
|
||||
(init-field [kind #f] [result-cb (λ args #f)]
|
||||
[id (new-id)] [name ""] [local-path ""]
|
||||
[host ""] [prefixes ""])
|
||||
(inherit-field settings icon parent)
|
||||
|
||||
(super-new
|
||||
[html-path "library-dialog.html"]
|
||||
[title (tr 'settings-library)]
|
||||
[icon (build-path rkt-gui-dir "rktplayer.png")]
|
||||
[quit-on-close #f]
|
||||
)
|
||||
|
||||
(define initialized #f)
|
||||
(define btn-ok #f)
|
||||
(define btn-cancel #f)
|
||||
(define lbl-name #f)
|
||||
(define lbl-local-path #f)
|
||||
(define btn-browse #f)
|
||||
(define lbl-host #f)
|
||||
(define lbl-prefixes #f)
|
||||
(define inp-local-path #f)
|
||||
(define inp-name #f)
|
||||
(define inp-host #f)
|
||||
(define inp-prefixes #f)
|
||||
|
||||
(define/public (set-labels)
|
||||
(send btn-ok set-innerHTML! (tr 'ok))
|
||||
(send btn-cancel set-innerHTML! (tr 'cancel))
|
||||
(send lbl-name set-innerHTML! (tr 'name))
|
||||
(send lbl-local-path set-innerHTML! (tr 'local-path))
|
||||
(send lbl-host set-innerHTML! (tr 'host))
|
||||
(send lbl-prefixes set-innerHTML! (tr 'prefixes))
|
||||
(send btn-browse set-innerHTML! (tr 'browse))
|
||||
)
|
||||
|
||||
(define (get el)
|
||||
(let ((str (send el get)))
|
||||
(string-trim str)))
|
||||
|
||||
(define/public (select-library)
|
||||
(let* ((music-library (get inp-local-path))
|
||||
(dir (send this choose-dir
|
||||
(tr 'choose-lib-folder)
|
||||
music-library
|
||||
)))
|
||||
(displayln "Directory kiezen")
|
||||
(if (eq? dir 'showing)
|
||||
'done
|
||||
(unless (eq? dir #f)
|
||||
(send inp-local-path set! dir))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/override (page-loaded oke)
|
||||
(unless initialized
|
||||
(when oke
|
||||
(set! initialized #t)
|
||||
(set! btn-ok (send this element 'ok))
|
||||
(set! btn-cancel (send this element 'cancel))
|
||||
(set! lbl-name (send this element 'lbl-name))
|
||||
(set! lbl-local-path (send this element 'lbl-local-path))
|
||||
(set! lbl-host (send this element 'lbl-host))
|
||||
(set! lbl-prefixes (send this element 'lbl-prefixes))
|
||||
(set! inp-name (send this element 'name))
|
||||
(set! inp-local-path (send this element 'local-path))
|
||||
(set! btn-browse (send this element 'browse))
|
||||
(set! inp-host (send this element 'host))
|
||||
(set! inp-prefixes (send this element 'prefixes))
|
||||
|
||||
(send inp-name set! name)
|
||||
(send inp-local-path set! local-path)
|
||||
(send inp-host set! host)
|
||||
(send inp-prefixes set! prefixes)
|
||||
|
||||
(send this set-labels)
|
||||
|
||||
(send this bind! 'browse 'click (λ (el evt data)
|
||||
(send this select-library)))
|
||||
|
||||
(send this bind! 'ok 'click (λ (el evt data)
|
||||
(let ((name (get inp-name))
|
||||
(local-path (get inp-local-path))
|
||||
(host (get inp-host))
|
||||
(prefixes (get inp-prefixes)))
|
||||
(result-cb id name local-path host prefixes)
|
||||
(send this close))))
|
||||
(send this bind! 'cancel 'click (λ (el evt data) (send this close)))
|
||||
(send this bind! 'dev 'click (λ args (send this devtools)))
|
||||
)
|
||||
))
|
||||
)
|
||||
)
|
||||
|
||||
(define settings%
|
||||
(class wv-dialog%
|
||||
(init-field [log-file #f])
|
||||
(inherit-field settings icon parent)
|
||||
|
||||
(super-new
|
||||
[html-path "settings.html"]
|
||||
[title (tr 'settings-title)]
|
||||
[icon (build-path rkt-gui-dir "rktplayer.png")]
|
||||
[quit-on-close #f]
|
||||
)
|
||||
|
||||
(define initialized #f)
|
||||
(define btn-ok #f)
|
||||
(define btn-cancel #f)
|
||||
(define btn-add #f)
|
||||
(define btn-edit #f)
|
||||
(define btn-remove #f)
|
||||
(define lbl-language #f)
|
||||
(define lbl-name #f)
|
||||
(define lbl-local-path #f)
|
||||
(define lbl-host #f)
|
||||
(define lbl-prefixes #f)
|
||||
(define lbl-lib #f)
|
||||
(define div-language #f)
|
||||
(define sel-language #f)
|
||||
|
||||
(define libs (new libraries% [settings settings]))
|
||||
|
||||
(define cfg (send settings clone 'settings))
|
||||
|
||||
(define/public (set-labels)
|
||||
(send btn-ok set-innerHTML! (tr 'ok))
|
||||
(send btn-cancel set-innerHTML! (tr 'cancel))
|
||||
(send btn-add set-innerHTML! (tr 'library-add))
|
||||
(send btn-edit set-innerHTML! (tr 'library-edit))
|
||||
(send btn-remove set-innerHTML! (tr 'library-remove))
|
||||
(send lbl-language set-innerHTML! (tr 'language))
|
||||
(send lbl-name set-innerHTML! (tr 'name))
|
||||
(send lbl-local-path set-innerHTML! (tr 'local-path))
|
||||
(send lbl-host set-innerHTML! (tr 'host))
|
||||
(send lbl-prefixes set-innerHTML! (tr 'prefixes))
|
||||
(send lbl-lib set-innerHTML! (tr 'lbl-libary-path))
|
||||
)
|
||||
|
||||
(define/public (update-libraries)
|
||||
(let ((count (send libs count)))
|
||||
(letrec ((f (λ (i)
|
||||
(if (= i count)
|
||||
'()
|
||||
(cons
|
||||
(let* ((id (send libs library-id i))
|
||||
(entry (begin
|
||||
(dbg-rktplayer "index = ~a, id = ~a, symbol? id = ~a" i id (symbol? id))
|
||||
(send libs get-library id)))
|
||||
(name (send entry get-name))
|
||||
(local-path (send entry get-local-path))
|
||||
(host (send entry get-host))
|
||||
(tr-attr (if (send entry is-current?)
|
||||
'((class "current"))
|
||||
'((class "none"))))
|
||||
)
|
||||
(list 'tr (append (list (list 'id (format "~a" id)))
|
||||
tr-attr)
|
||||
(list 'td (list '(class "name")) name)
|
||||
(list 'td '((class "path")) local-path)
|
||||
(list 'td '((class "host")) host)))
|
||||
(f (+ i 1)))))))
|
||||
(let* ((tbl (f 0))
|
||||
(el (send this element 'lib-body))
|
||||
(html (if (= count 0)
|
||||
""
|
||||
(apply string-append (map xexpr->string tbl)))))
|
||||
(displayln html)
|
||||
(send el set-innerHTML! html)
|
||||
(send this bind! "table.libraries tr" 'click
|
||||
(lambda (el evt data)
|
||||
(let* ((new-id (string->symbol (send el attr 'id)))
|
||||
(new-lib (send libs get-library new-id))
|
||||
(cur-lib (send libs current-library))
|
||||
)
|
||||
(displayln new-id)
|
||||
(displayln new-lib)
|
||||
(displayln cur-lib)
|
||||
(unless (eq? cur-lib #f)
|
||||
(let ((cur-el (send this element (send cur-lib get-id))))
|
||||
(send cur-el remove-class! 'current)
|
||||
(send cur-lib set-current! #f)))
|
||||
(unless (eq? new-id #f)
|
||||
(let ((new-el (send this element new-id)))
|
||||
(displayln new-el)
|
||||
(displayln (send new-el attr 'id))
|
||||
(send new-el set-attr! '(test "NEE!"))
|
||||
(send new-el add-class! "current")
|
||||
(send new-lib set-current! #t)
|
||||
(send libs update-library new-lib)))
|
||||
)))
|
||||
))))
|
||||
|
||||
(define/public (add-library)
|
||||
(let* ((cb (λ (id name local-path host prefixes)
|
||||
(send libs add-library (new library% [id id]
|
||||
[name name] [local-path local-path]
|
||||
[host host] [prefixes prefixes] [current #f]))
|
||||
(send this update-libraries)))
|
||||
(dlg (new library-dlg% [parent this]
|
||||
[settings (send settings clone 'library-dlg)]
|
||||
[kind 'add] [result-cb cb])))
|
||||
(send dlg show)))
|
||||
|
||||
(define/override (page-loaded oke)
|
||||
(unless initialized
|
||||
(when oke
|
||||
(set! initialized #t)
|
||||
(set! btn-ok (send this element 'ok))
|
||||
(set! btn-cancel (send this element 'cancel))
|
||||
(set! btn-add (send this element 'add))
|
||||
(set! btn-edit (send this element 'edit))
|
||||
(set! btn-remove (send this element 'remove))
|
||||
(set! lbl-language (send this element 'lbl-language))
|
||||
(set! lbl-lib (send this element 'lbl-libary-path))
|
||||
(set! lbl-name (send this element 'lbl-name))
|
||||
(set! lbl-local-path (send this element 'lbl-local-path))
|
||||
(set! lbl-host (send this element 'lbl-host))
|
||||
(set! lbl-prefixes (send this element 'lbl-prefixes))
|
||||
(set! div-language (send this element 'language))
|
||||
|
||||
(send this set-labels)
|
||||
|
||||
(send div-language set-innerHTML! (make-select-list 'sel-lang (languages) (current-lang)))
|
||||
|
||||
(send this bind! 'sel-lang 'change (λ (el evt data)
|
||||
(let ((lang (string->symbol
|
||||
(format "~a" (hash-ref data 'value (current-lang))))))
|
||||
(set-lang! lang)
|
||||
(send cfg set! 'language lang)
|
||||
(send this set-labels))))
|
||||
|
||||
(send this bind! 'ok 'click (λ (el evt data) (send this close)))
|
||||
(send this bind! 'cancel 'click (λ (el evt data) (send this close)))
|
||||
(send this bind! 'dev 'click (λ args (send this devtools)))
|
||||
(send this bind! 'add 'click (λ (el evt data) (send this add-library)))
|
||||
(send this bind! 'edit 'click (λ (el evt data) (send this edit-library)))
|
||||
(send this bind! 'remove 'click (λ (el evt data) (send this remove-library)))
|
||||
|
||||
(send this update-libraries)
|
||||
)
|
||||
)
|
||||
(info-rktplayer "page loaded")
|
||||
)
|
||||
|
||||
(begin
|
||||
#t)
|
||||
)
|
||||
)
|
||||
Reference in New Issue
Block a user