From f5fdc38e6708c031213e95553b0d26f7efeb4ebb Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Sat, 8 Aug 2026 14:29:01 +0200 Subject: [PATCH] Complete refactoring for rktplayer, in order to make it play on DLNA renderers and also use UpNP media server resources. --- .gitignore | 1 + AGENTS.md | 10 + dlna-player.rkt | 373 ------------ dlna.rkt | 40 -- gui.rkt => gui/gui.rkt | 782 +++++++++++++++++------- gui/{ => html}/buttons/next.svg | 2 +- gui/{ => html}/buttons/pause.svg | 10 +- gui/{ => html}/buttons/play.svg | 0 gui/{ => html}/buttons/previous.svg | 2 +- gui/{ => html}/buttons/repeat-off.svg | 0 gui/{ => html}/buttons/repeat-one.svg | 8 +- gui/{ => html}/buttons/repeat.svg | 8 +- gui/{ => html}/buttons/stop.svg | 0 gui/{ => html}/buttons/volume-high.svg | 8 +- gui/{ => html}/buttons/volume-low.svg | 8 +- gui/{ => html}/buttons/volume-mute.svg | 8 +- gui/{ => html}/devtools.svg | 0 gui/{ => html}/favicon.ico | Bin gui/html/library-dialog.html | 56 ++ gui/{ => html}/menu.js | 0 gui/{ => html}/rktplayer.html | 3 +- gui/{ => html}/rktplayer.png | Bin gui/{ => html}/rktplayer.svg | 0 gui/{ => html}/settings.html | 18 +- gui/{ => html}/styles.css | 23 +- gui/library-dialog.html | 41 -- gui/settings.rkt | 800 +++++++++++++++++++++++++ translate.rkt => gui/translate.rkt | 79 ++- tray.rkt => gui/tray.rkt | 6 +- info.rkt | 8 +- libraries.rkt | 125 ---- library/base/booklet-provider.rkt | 12 + library/base/image-provider.rkt | 13 + library/base/media-container.rkt | 52 ++ library/base/media-item.rkt | 59 ++ library/base/media-library.rkt | 51 ++ library/base/media-resource.rkt | 97 +++ library/base/tag-data-provider.rkt | 10 + library/base/track.rkt | 205 +++++++ library/libraries-config.rkt | 149 +++++ library/library-browser.rkt | 82 +++ library/library-cfg.rkt | 71 +++ library/library-factory.rkt | 108 ++++ library/library-filesystem.rkt | 66 ++ library/library-item.rkt | 74 +++ library/library-media-server.rkt | 219 +++++++ library/library-ref.rkt | 7 + library/mc-filesystem.rkt | 82 +++ library/mc-media-server.rkt | 86 +++ library/track-filesystem-providers.rkt | 159 +++++ library/track-filesystem.rkt | 116 ++++ library/track-media-server.rkt | 191 ++++++ library/track-store.rkt | 175 ++++++ library/track-tag-data.rkt | 7 + utils.rkt => misc/utils.rkt | 98 ++- music-library.rkt | 53 -- player.rkt => play/base/player.rkt | 92 +-- play/base/renderer.rkt | 163 +++++ play/dlna-player.rkt | 588 ++++++++++++++++++ play/dlna.rkt | 113 ++++ play/playlist-cache.rkt | 280 +++++++++ play/playlist-entry.rkt | 194 ++++++ play/playlist-gui.rkt | 218 +++++++ play/playlist.rkt | 487 +++++++++++++++ play/renderer-sonos.rkt | 29 + play/renderer-upnp.rkt | 35 ++ playlist.rkt | 438 -------------- rktplayer.rkt | 28 +- settings.rkt | 274 --------- 69 files changed, 5953 insertions(+), 1647 deletions(-) create mode 100644 AGENTS.md delete mode 100644 dlna-player.rkt delete mode 100644 dlna.rkt rename gui.rkt => gui/gui.rkt (50%) rename gui/{ => html}/buttons/next.svg (99%) rename gui/{ => html}/buttons/pause.svg (98%) rename gui/{ => html}/buttons/play.svg (100%) rename gui/{ => html}/buttons/previous.svg (99%) rename gui/{ => html}/buttons/repeat-off.svg (100%) rename gui/{ => html}/buttons/repeat-one.svg (99%) rename gui/{ => html}/buttons/repeat.svg (99%) rename gui/{ => html}/buttons/stop.svg (100%) rename gui/{ => html}/buttons/volume-high.svg (99%) rename gui/{ => html}/buttons/volume-low.svg (99%) rename gui/{ => html}/buttons/volume-mute.svg (99%) rename gui/{ => html}/devtools.svg (100%) rename gui/{ => html}/favicon.ico (100%) create mode 100644 gui/html/library-dialog.html rename gui/{ => html}/menu.js (100%) rename gui/{ => html}/rktplayer.html (94%) rename gui/{ => html}/rktplayer.png (100%) rename gui/{ => html}/rktplayer.svg (100%) rename gui/{ => html}/settings.html (61%) rename gui/{ => html}/styles.css (94%) delete mode 100644 gui/library-dialog.html create mode 100644 gui/settings.rkt rename translate.rkt => gui/translate.rkt (68%) rename tray.rkt => gui/tray.rkt (97%) delete mode 100644 libraries.rkt create mode 100644 library/base/booklet-provider.rkt create mode 100644 library/base/image-provider.rkt create mode 100644 library/base/media-container.rkt create mode 100644 library/base/media-item.rkt create mode 100644 library/base/media-library.rkt create mode 100644 library/base/media-resource.rkt create mode 100644 library/base/tag-data-provider.rkt create mode 100644 library/base/track.rkt create mode 100644 library/libraries-config.rkt create mode 100644 library/library-browser.rkt create mode 100644 library/library-cfg.rkt create mode 100644 library/library-factory.rkt create mode 100644 library/library-filesystem.rkt create mode 100644 library/library-item.rkt create mode 100644 library/library-media-server.rkt create mode 100644 library/library-ref.rkt create mode 100644 library/mc-filesystem.rkt create mode 100644 library/mc-media-server.rkt create mode 100644 library/track-filesystem-providers.rkt create mode 100644 library/track-filesystem.rkt create mode 100644 library/track-media-server.rkt create mode 100644 library/track-store.rkt create mode 100644 library/track-tag-data.rkt rename utils.rkt => misc/utils.rkt (67%) delete mode 100644 music-library.rkt rename player.rkt => play/base/player.rkt (74%) create mode 100644 play/base/renderer.rkt create mode 100644 play/dlna-player.rkt create mode 100644 play/dlna.rkt create mode 100644 play/playlist-cache.rkt create mode 100644 play/playlist-entry.rkt create mode 100644 play/playlist-gui.rkt create mode 100644 play/playlist.rkt create mode 100644 play/renderer-sonos.rkt create mode 100644 play/renderer-upnp.rkt delete mode 100644 playlist.rkt delete mode 100644 settings.rkt diff --git a/.gitignore b/.gitignore index c0a9c74..8c944b9 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,4 @@ compiled/ /*.bak /gui/*.bak +/gui/html/*.bak diff --git a/AGENTS.md b/AGENTS.md new file mode 100644 index 0000000..d16b163 --- /dev/null +++ b/AGENTS.md @@ -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. diff --git a/dlna-player.rkt b/dlna-player.rkt deleted file mode 100644 index dd4f94c..0000000 --- a/dlna-player.rkt +++ /dev/null @@ -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")))) diff --git a/dlna.rkt b/dlna.rkt deleted file mode 100644 index ba580f1..0000000 --- a/dlna.rkt +++ /dev/null @@ -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)) - ) - ) - ) diff --git a/gui.rkt b/gui/gui.rkt similarity index 50% rename from gui.rkt rename to gui/gui.rkt index 54c941a..f44dba0 100644 --- a/gui.rkt +++ b/gui/gui.rkt @@ -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) diff --git a/gui/buttons/next.svg b/gui/html/buttons/next.svg similarity index 99% rename from gui/buttons/next.svg rename to gui/html/buttons/next.svg index c4a7be9..bc72e33 100644 --- a/gui/buttons/next.svg +++ b/gui/html/buttons/next.svg @@ -6,4 +6,4 @@ d="M13.0502 2.74989C13.0502 2.44613 12.804 2.19989 12.5002 2.19989C12.1965 2.19989 11.9502 2.44613 11.9502 2.74989V7.2825C11.9046 7.18802 11.8295 7.10851 11.7334 7.05776L2.73338 2.30776C2.5784 2.22596 2.3919 2.23127 2.24182 2.32176C2.09175 2.41225 2 2.57471 2 2.74995V12.25C2 12.4252 2.09175 12.5877 2.24182 12.6781C2.3919 12.7686 2.5784 12.7739 2.73338 12.6921L11.7334 7.94214C11.8295 7.89139 11.9046 7.81188 11.9502 7.7174V12.2499C11.9502 12.5536 12.1965 12.7999 12.5002 12.7999C12.804 12.7999 13.0502 12.5536 13.0502 12.2499V2.74989ZM3 11.4207V3.5792L10.4288 7.49995L3 11.4207Z" fill="#000000" /> - \ No newline at end of file + diff --git a/gui/buttons/pause.svg b/gui/html/buttons/pause.svg similarity index 98% rename from gui/buttons/pause.svg rename to gui/html/buttons/pause.svg index 3ebf5cc..2f0d8a2 100644 --- a/gui/buttons/pause.svg +++ b/gui/html/buttons/pause.svg @@ -1,5 +1,5 @@ - - - - - \ No newline at end of file + + + + + diff --git a/gui/buttons/play.svg b/gui/html/buttons/play.svg similarity index 100% rename from gui/buttons/play.svg rename to gui/html/buttons/play.svg diff --git a/gui/buttons/previous.svg b/gui/html/buttons/previous.svg similarity index 99% rename from gui/buttons/previous.svg rename to gui/html/buttons/previous.svg index b49a12c..54a2b04 100644 --- a/gui/buttons/previous.svg +++ b/gui/html/buttons/previous.svg @@ -6,4 +6,4 @@ d="M1.94976 2.74989C1.94976 2.44613 2.196 2.19989 2.49976 2.19989C2.80351 2.19989 3.04976 2.44613 3.04976 2.74989V7.2825C3.0954 7.18802 3.17046 7.10851 3.26662 7.05776L12.2666 2.30776C12.4216 2.22596 12.6081 2.23127 12.7582 2.32176C12.9083 2.41225 13 2.57471 13 2.74995V12.25C13 12.4252 12.9083 12.5877 12.7582 12.6781C12.6081 12.7686 12.4216 12.7739 12.2666 12.6921L3.26662 7.94214C3.17046 7.89139 3.0954 7.81188 3.04976 7.7174V12.2499C3.04976 12.5536 2.80351 12.7999 2.49976 12.7999C2.196 12.7999 1.94976 12.5536 1.94976 12.2499V2.74989ZM4.57122 7.49995L12 11.4207V3.5792L4.57122 7.49995Z" fill="#000000" /> - \ No newline at end of file + diff --git a/gui/buttons/repeat-off.svg b/gui/html/buttons/repeat-off.svg similarity index 100% rename from gui/buttons/repeat-off.svg rename to gui/html/buttons/repeat-off.svg diff --git a/gui/buttons/repeat-one.svg b/gui/html/buttons/repeat-one.svg similarity index 99% rename from gui/buttons/repeat-one.svg rename to gui/html/buttons/repeat-one.svg index 1fa64c8..880092e 100644 --- a/gui/buttons/repeat-one.svg +++ b/gui/html/buttons/repeat-one.svg @@ -1,4 +1,4 @@ - - - - \ No newline at end of file + + + + diff --git a/gui/buttons/repeat.svg b/gui/html/buttons/repeat.svg similarity index 99% rename from gui/buttons/repeat.svg rename to gui/html/buttons/repeat.svg index 06132f3..c9386b3 100644 --- a/gui/buttons/repeat.svg +++ b/gui/html/buttons/repeat.svg @@ -1,4 +1,4 @@ - - - - \ No newline at end of file + + + + diff --git a/gui/buttons/stop.svg b/gui/html/buttons/stop.svg similarity index 100% rename from gui/buttons/stop.svg rename to gui/html/buttons/stop.svg diff --git a/gui/buttons/volume-high.svg b/gui/html/buttons/volume-high.svg similarity index 99% rename from gui/buttons/volume-high.svg rename to gui/html/buttons/volume-high.svg index bcb2d46..f6d0a65 100644 --- a/gui/buttons/volume-high.svg +++ b/gui/html/buttons/volume-high.svg @@ -1,4 +1,4 @@ - - - - \ No newline at end of file + + + + diff --git a/gui/buttons/volume-low.svg b/gui/html/buttons/volume-low.svg similarity index 99% rename from gui/buttons/volume-low.svg rename to gui/html/buttons/volume-low.svg index acaeef9..850fb7f 100644 --- a/gui/buttons/volume-low.svg +++ b/gui/html/buttons/volume-low.svg @@ -1,4 +1,4 @@ - - - - \ No newline at end of file + + + + diff --git a/gui/buttons/volume-mute.svg b/gui/html/buttons/volume-mute.svg similarity index 99% rename from gui/buttons/volume-mute.svg rename to gui/html/buttons/volume-mute.svg index 8f4dbf6..c5fd45c 100644 --- a/gui/buttons/volume-mute.svg +++ b/gui/html/buttons/volume-mute.svg @@ -1,4 +1,4 @@ - - - - \ No newline at end of file + + + + diff --git a/gui/devtools.svg b/gui/html/devtools.svg similarity index 100% rename from gui/devtools.svg rename to gui/html/devtools.svg diff --git a/gui/favicon.ico b/gui/html/favicon.ico similarity index 100% rename from gui/favicon.ico rename to gui/html/favicon.ico diff --git a/gui/html/library-dialog.html b/gui/html/library-dialog.html new file mode 100644 index 0000000..f6f8c16 --- /dev/null +++ b/gui/html/library-dialog.html @@ -0,0 +1,56 @@ + + + + + + RktPlayer - A music player - library entry + + +
+
+ + +
+
+
+ + +
+
+
+ +
+ + +
+
+
+ +
+
+ + + +
+ + diff --git a/gui/menu.js b/gui/html/menu.js similarity index 100% rename from gui/menu.js rename to gui/html/menu.js diff --git a/gui/rktplayer.html b/gui/html/rktplayer.html similarity index 94% rename from gui/rktplayer.html rename to gui/html/rktplayer.html index 5d94da5..d35f22b 100644 --- a/gui/rktplayer.html +++ b/gui/html/rktplayer.html @@ -22,7 +22,7 @@
- +
@@ -53,6 +53,7 @@ +
diff --git a/gui/rktplayer.png b/gui/html/rktplayer.png similarity index 100% rename from gui/rktplayer.png rename to gui/html/rktplayer.png diff --git a/gui/rktplayer.svg b/gui/html/rktplayer.svg similarity index 100% rename from gui/rktplayer.svg rename to gui/html/rktplayer.svg diff --git a/gui/settings.html b/gui/html/settings.html similarity index 61% rename from gui/settings.html rename to gui/html/settings.html index bc5914d..629ca03 100644 --- a/gui/settings.html +++ b/gui/html/settings.html @@ -16,7 +16,7 @@
- + @@ -26,6 +26,22 @@ +
+
+ +
+
+ +
+ + + + + + + + +
NameLogarithmic volume
diff --git a/gui/styles.css b/gui/html/styles.css similarity index 94% rename from gui/styles.css rename to gui/html/styles.css index 9a74e82..d50335f 100644 --- a/gui/styles.css +++ b/gui/html/styles.css @@ -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%, diff --git a/gui/library-dialog.html b/gui/library-dialog.html deleted file mode 100644 index f3894cc..0000000 --- a/gui/library-dialog.html +++ /dev/null @@ -1,41 +0,0 @@ - - - - - - RktPlayer - A music player - library entry - - -
-
- - Action -
-
-
- - -
-
- -
- - -
-
-
- - -
-
- - -
-
-
- - - -
- - \ No newline at end of file diff --git a/gui/settings.rkt b/gui/settings.rkt new file mode 100644 index 0000000..ac28279 --- /dev/null +++ b/gui/settings.rkt @@ -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) + ) + ) diff --git a/translate.rkt b/gui/translate.rkt similarity index 68% rename from translate.rkt rename to gui/translate.rkt index 474a824..23cc10d 100644 --- a/translate.rkt +++ b/gui/translate.rkt @@ -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")) ) diff --git a/tray.rkt b/gui/tray.rkt similarity index 97% rename from tray.rkt rename to gui/tray.rkt index 56f6307..fbc254a 100644 --- a/tray.rkt +++ b/gui/tray.rkt @@ -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% @@ -76,4 +76,4 @@ ) ) - ) \ No newline at end of file + ) diff --git a/info.rkt b/info.rkt index 001943d..bdfa308 100644 --- a/info.rkt +++ b/info.rkt @@ -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) - - diff --git a/libraries.rkt b/libraries.rkt deleted file mode 100644 index 4f3c2f0..0000000 --- a/libraries.rkt +++ /dev/null @@ -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= 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)))) - - )) \ No newline at end of file diff --git a/library/base/booklet-provider.rkt b/library/base/booklet-provider.rkt new file mode 100644 index 0000000..1d15113 --- /dev/null +++ b/library/base/booklet-provider.rkt @@ -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))) diff --git a/library/base/image-provider.rkt b/library/base/image-provider.rkt new file mode 100644 index 0000000..411b92f --- /dev/null +++ b/library/base/image-provider.rkt @@ -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))) diff --git a/library/base/media-container.rkt b/library/base/media-container.rkt new file mode 100644 index 0000000..a72ac5b --- /dev/null +++ b/library/base/media-container.rkt @@ -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)) diff --git a/library/base/media-item.rkt b/library/base/media-item.rkt new file mode 100644 index 0000000..cb6dea5 --- /dev/null +++ b/library/base/media-item.rkt @@ -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])))) diff --git a/library/base/media-library.rkt b/library/base/media-library.rkt new file mode 100644 index 0000000..bc3c865 --- /dev/null +++ b/library/base/media-library.rkt @@ -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))) diff --git a/library/base/media-resource.rkt b/library/base/media-resource.rkt new file mode 100644 index 0000000..0917693 --- /dev/null +++ b/library/base/media-resource.rkt @@ -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?))) diff --git a/library/base/tag-data-provider.rkt b/library/base/tag-data-provider.rkt new file mode 100644 index 0000000..061d064 --- /dev/null +++ b/library/base/tag-data-provider.rkt @@ -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))) diff --git a/library/base/track.rkt b/library/base/track.rkt new file mode 100644 index 0000000..71292d6 --- /dev/null +++ b/library/base/track.rkt @@ -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-cilog) + (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?))) diff --git a/library/libraries-config.rkt b/library/libraries-config.rkt new file mode 100644 index 0000000..65661e9 --- /dev/null +++ b/library/libraries-config.rkt @@ -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) + (stringlibrary-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))) diff --git a/library/library-browser.rkt b/library/library-browser.rkt new file mode 100644 index 0000000..39a31e8 --- /dev/null +++ b/library/library-browser.rkt @@ -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!))) diff --git a/library/library-cfg.rkt b/library/library-cfg.rkt new file mode 100644 index 0000000..6181e06 --- /dev/null +++ b/library/library-cfg.rkt @@ -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))) diff --git a/library/library-factory.rkt b/library/library-factory.rkt new file mode 100644 index 0000000..8b7d2ba --- /dev/null +++ b/library/library-factory.rkt @@ -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))) diff --git a/library/library-filesystem.rkt b/library/library-filesystem.rkt new file mode 100644 index 0000000..4da995b --- /dev/null +++ b/library/library-filesystem.rkt @@ -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]))) diff --git a/library/library-item.rkt b/library/library-item.rkt new file mode 100644 index 0000000..1c79c20 --- /dev/null +++ b/library/library-item.rkt @@ -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)))) diff --git a/library/library-media-server.rkt b/library/library-media-server.rkt new file mode 100644 index 0000000..577cae3 --- /dev/null +++ b/library/library-media-server.rkt @@ -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]))) diff --git a/library/library-ref.rkt b/library/library-ref.rkt new file mode 100644 index 0000000..a4b2cb6 --- /dev/null +++ b/library/library-ref.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide (struct-out library-ref)) + +(struct library-ref + (library-id kind version) + #:prefab) diff --git a/library/mc-filesystem.rkt b/library/mc-filesystem.rkt new file mode 100644 index 0000000..7c9dcae --- /dev/null +++ b/library/mc-filesystem.rkt @@ -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) + pathstring 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))) diff --git a/library/track-filesystem.rkt b/library/track-filesystem.rkt new file mode 100644 index 0000000..1f33f34 --- /dev/null +++ b/library/track-filesystem.rkt @@ -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))))) diff --git a/library/track-media-server.rkt b/library/track-media-server.rkt new file mode 100644 index 0000000..141e748 --- /dev/null +++ b/library/track-media-server.rkt @@ -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%)]))) diff --git a/library/track-store.rkt b/library/track-store.rkt new file mode 100644 index 0000000..3277b9b --- /dev/null +++ b/library/track-store.rkt @@ -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)))) diff --git a/library/track-tag-data.rkt b/library/track-tag-data.rkt new file mode 100644 index 0000000..c6c74a7 --- /dev/null +++ b/library/track-tag-data.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide (struct-out track-tag-data)) + +(struct track-tag-data + (title artist album number length) + #:prefab) diff --git a/utils.rkt b/misc/utils.rkt similarity index 67% rename from utils.rkt rename to misc/utils.rkt index 16f8b80..e239d7a 100644 --- a/utils.rkt +++ b/misc/utils.rkt @@ -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)) - \ No newline at end of file +(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?))))) diff --git a/music-library.rkt b/music-library.rkt deleted file mode 100644 index 03af7b5..0000000 --- a/music-library.rkt +++ /dev/null @@ -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)) - )) - ) - ) - - diff --git a/player.rkt b/play/base/player.rkt similarity index 74% rename from player.rkt rename to play/base/player.rkt index e129f14..429ae5f 100644 --- a/player.rkt +++ b/play/base/player.rkt @@ -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) diff --git a/play/base/renderer.rkt b/play/base/renderer.rkt new file mode 100644 index 0000000..9acf965 --- /dev/null +++ b/play/base/renderer.rkt @@ -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))) diff --git a/play/dlna-player.rkt b/play/dlna-player.rkt new file mode 100644 index 0000000..4da6bcc --- /dev/null +++ b/play/dlna-player.rkt @@ -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")))) diff --git a/play/dlna.rkt b/play/dlna.rkt new file mode 100644 index 0000000..97c06ad --- /dev/null +++ b/play/dlna.rkt @@ -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:\"/\\\\|?*]" + (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))) diff --git a/play/playlist-entry.rkt b/play/playlist-entry.rkt new file mode 100644 index 0000000..d94b6aa --- /dev/null +++ b/play/playlist-entry.rkt @@ -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)))) diff --git a/play/playlist-gui.rkt b/play/playlist-gui.rkt new file mode 100644 index 0000000..82315a9 --- /dev/null +++ b/play/playlist-gui.rkt @@ -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")) diff --git a/play/playlist.rkt b/play/playlist.rkt new file mode 100644 index 0000000..f01c715 --- /dev/null +++ b/play/playlist.rkt @@ -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)) diff --git a/play/renderer-sonos.rkt b/play/renderer-sonos.rkt new file mode 100644 index 0000000..63aee08 --- /dev/null +++ b/play/renderer-sonos.rkt @@ -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]))) diff --git a/play/renderer-upnp.rkt b/play/renderer-upnp.rkt new file mode 100644 index 0000000..a3712e2 --- /dev/null +++ b/play/renderer-upnp.rkt @@ -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]))) diff --git a/playlist.rkt b/playlist.rkt deleted file mode 100644 index b45bb5d..0000000 --- a/playlist.rkt +++ /dev/null @@ -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-cistring 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))) - ) - ) - ) - \ No newline at end of file diff --git a/rktplayer.rkt b/rktplayer.rkt index 08c3da1..1131b00 100644 --- a/rktplayer.rkt +++ b/rktplayer.rkt @@ -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) - diff --git a/settings.rkt b/settings.rkt deleted file mode 100644 index 1be1c97..0000000 --- a/settings.rkt +++ /dev/null @@ -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) - ) - )