From e54f6f4a5f598aa6efc44009c163f5cbcfd561a2 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Fri, 31 Jul 2026 17:03:19 +0200 Subject: [PATCH] DLNA playback --- dlna-player.rkt | 373 ++++++++++++++++++++ dlna.rkt | 40 +++ gui.rkt | 93 ++++- gui.rkt-autorec.gui | 802 ++++++++++++++++++++++++++++++++++++++++++++ gui/rktplayer.html | 1 + player.rkt | 7 +- translate.rkt | 15 + 7 files changed, 1325 insertions(+), 6 deletions(-) create mode 100644 dlna-player.rkt create mode 100644 dlna.rkt create mode 100644 gui.rkt-autorec.gui diff --git a/dlna-player.rkt b/dlna-player.rkt new file mode 100644 index 0000000..070d14f --- /dev/null +++ b/dlna-player.rkt @@ -0,0 +1,373 @@ +#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 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 new file mode 100644 index 0000000..ba580f1 --- /dev/null +++ b/dlna.rkt @@ -0,0 +1,40 @@ +#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.rkt index 617c7b2..54c941a 100644 --- a/gui.rkt +++ b/gui.rkt @@ -11,8 +11,10 @@ "translate.rkt" "playlist.rkt" "player.rkt" + "dlna-player.rkt" "settings.rkt" "libraries.rkt" + "dlna.rkt" ) (provide @@ -24,14 +26,29 @@ (define player-menu - (λ () + (λ (renderers 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) - ) + )) + (wv-menu-item 'm-players (tr 'players) + #:submenu (apply wv-menu + (append + (list 'dlna-menu + (wv-menu-item 'm-play-local (tr 'play-local)) + (wv-menu-item 'm-check-dlna (tr 'check-dlna))) + (let ((rndr-idx 0)) + (map (λ (r) + (let* ((idx rndr-idx) + (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)))) ) ))) @@ -61,6 +78,7 @@ (define el-format #f) (define el-channels #f) (define el-bits #f) + (define el-message #f) (define cfg (send settings clone 'settings)) (define current-tab 0) @@ -121,6 +139,18 @@ ) ) + (define/public (message! msg #:clear [clear #f]) + (when (eq? el-message #f) + (set! el-message (send this element 'message))) + (unless (eq? el-message #f) + (send el-message set-innerHTML! msg) + (when clear + (void + (thread (λ () + (sleep 10) + (send this message! "" #:clear #f))))) + )) + (define current-track-nr #f) (define (update-track-nr nr) @@ -346,7 +376,14 @@ ) ) - (define player (new player% + (define player #f) + (define dlna-renderers '()) + + (define/public (play-local) + (unless (eq? player #f) + (send player stop) + (send player quit)) + (set! player (new player% [time-updater update-time] [track-nr-updater update-track-nr] [state-updater update-state] @@ -354,6 +391,49 @@ [audio-info-cb update-audio-info] [settings settings] )) + (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))) + (unless (eq? player #f) + (send player stop) + (send player quit)) + (set! player + (new dlna-player% + [renderer renderer] + [time-updater update-time] + [track-nr-updater update-track-nr] + [state-updater update-state] + [repeat-updater update-repeat] + [audio-info-cb update-audio-info] + [settings settings])) + (unless (eq? playlist #f) + (send player playlist! playlist)))) + + (define/public (dlna-query-busy) + (send this message! (tr 'dlna-query-busy) #:clear #t)) + + (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)) + + (define/public (check-dlna) + (check-dlna-players this)) (define inner-html-handlers (make-hash)) @@ -407,11 +487,13 @@ (set! el-channels (send this element 'channels)) (set! el-format (send this element 'format)) - (send this set-menu! (player-menu)) + (send this set-menu! (player-menu '() (λ (id idx) #t))) (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-check-dlna (λ () (send this check-dlna))) (dbg-rktplayer "page-loaded, playlist = ~a" playlist) (send this update-tabs) @@ -664,6 +746,7 @@ (let* ((volume-meter (send this element 'volume-meter)) (volume-display (send volume-meter display)) ) + (display "volume-display = ") (write volume-display) (newline) (if (eq? volume-display 'block) (send volume-meter display 'none) (begin @@ -723,6 +806,8 @@ #f) (begin + (dbg-rktplayer "Initializing local player") + (play-local) (dbg-rktplayer "Initalizing gui") (dbg-rktplayer "ICON: ~a" (get-field icon this)) (let ((lang (send settings get 'lang 'en))) diff --git a/gui.rkt-autorec.gui b/gui.rkt-autorec.gui new file mode 100644 index 0000000..af57414 --- /dev/null +++ b/gui.rkt-autorec.gui @@ -0,0 +1,802 @@ +#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" + "settings.rkt" + "libraries.rkt" + "dlna.rkt" + ) + +(provide + (all-from-out racket-webview) + rktplayer% + ) + +(define-runtime-path rkt-gui-dir "gui") + + +(define player-menu + (λ (renderers 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) + )) + (wv-menu-item 'm-players (tr 'players) + #:submenu (apply wv-menu + (append + (list 'dlna-menu + (wv-menu-item 'm-play-local (tr 'play-local)) + (wv-menu-item 'm-check-dlna (tr 'check-dlna))) + (let ((rndr-idx 0)) + (map (λ (r) + (let* ((idx rndr-idx) + (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)))) + ) + ))) + +(define rktplayer% + (class wv-window% + (init-field [log-file #f]) + (inherit-field settings icon) + + (super-new + [html-path "rktplayer.html"] + [title "Racket Music Player"] + [icon (build-path rkt-gui-dir "rktplayer.png")] + [quit-on-close #f] + ) + + (define initialized (make-semaphore 0)) + + (define closed #f) + (define el-seeker #f) + (define el-volume #f) + (define el-vol-perc #f) + (define el-library #f) + (define el-playlist #f) + (define el-at #f) + (define el-length #f) + (define el-rate #f) + (define el-format #f) + (define el-channels #f) + (define el-bits #f) + (define el-message #f) + (define cfg (send settings clone 'settings)) + + (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 current-music-path #f) + (define playlist #f) + + (define current-at-seconds 0) + (define current-length-seconds 0) + + (define/public (update-volume) + (let ((el (send this element 'volume-percentage))) + (let ((percentage (send player get-volume))) + (send el set-innerHTML! (sprintf "%s %d%" (tr 'volume) percentage))) + ) + ) + + (define (update-time at-seconds length-seconds) + (let ((as (inexact->exact (round at-seconds))) + (ls (inexact->exact (round length-seconds)))) + + (when (or (not (= current-at-seconds as)) + (not (= current-length-seconds ls))) + (set! current-at-seconds as) + (set! current-length-seconds ls) + (let ((as-str (sprintf "%02d:%02d:%02d" + (quotient as 3600) + (quotient (remainder as 3600) 60) + (remainder (remainder as 3600) 60))) + (ls-str (sprintf "%02d:%02d:%02d" + (quotient ls 3600) + (quotient (remainder ls 3600) 60) + (remainder (remainder ls 3600) 60))) + ) + (unless closed + (send el-at set-innerHTML! as-str) + (send el-length set-innerHTML! ls-str) + (let ((seeker (if (= ls 0) + 0.0 + (exact->inexact (/ (* 100 as) ls))))) + (send el-seeker set! (format "~a" seeker))) + ) + ) + (send this update-volume) + ) + ) + ) + + (define/public (message! msg #:clear [clear #f]) + (when (eq? el-message #f) + (set! el-message (send this element 'message))) + (unless (eq? el-message #f) + (send el-message set-innerHTML! msg) + (when clear + (void + (thread (λ () + (sleep 10) + (send this message! "" #:clear #f))))) + )) + + (define current-track-nr #f) + + (define (update-track-nr nr) + (unless (or (eq? playlist #f) + (= (send playlist length) 0)) + (dbg-rktplayer "update-track-nr ~a" nr) + (let ((id (λ () (send playlist track-id current-track-nr))) ;string->symbol (format "track-~a" (+ current-track-nr 1))))) + (ct current-track-nr)) + + (dbg-rktplayer "Removing current") + (unless (eq? current-track-nr #f) + (dbg-rktplayer (format "current old track: ~a" (id))) + (let ((el (send this element (id)))) + (send el remove-class! "current"))) + + (set! current-track-nr nr) + + (dbg-rktplayer "Adding current") + (unless (eq? current-track-nr #f) + (dbg-rktplayer "current new track: ~a" (id)) + (let ((el (send this element (id)))) + (send el add-class! "current")) + + (dbg-rktplayer "Getting cover image") + (let* ((track (send playlist track current-track-nr)) + (img-file (build-path (find-system-path 'cache-dir) "rktplayer-cover-image")) + (stored-file (send track image->file img-file)) + ) + (dbg-rktplayer "image mimetype: ~a" (send track image->mimetype)) + (dbg-rktplayer "stored-file = ~a" stored-file) + (unless (eq? stored-file #f) + (dbg-rktplayer "Setting album art") + (let ((el (send this element 'album-art))) + (let ((html (format "" + (format "~a" stored-file) + (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)))))) + ))) + ) + ) + (dbg-rktplayer "Done updating track") + ) + ) + ) + + (define state #f) + (define current-play-image "buttons/play.svg") + + (define (set-play-button img) + (unless (string=? current-play-image img) + (set! current-play-image img) + (let ((btn (send this element 'play-img))) + (send btn set-attr! (list 'src img)) + ) + ) + ) + + (define (update-state st) + (unless (eq? st state) + (dbg-rktplayer "Changing to state ~a" st) + (let ((el (send this element 'paused))) + (cond ((or (eq? st 'playing) (eq? st 'play)) + (set-play-button "buttons/pause.svg") + (send el set-innerHTML! (list 'span (tr 'playing)))) + ((eq? st 'stopped) + (set-play-button "buttons/play.svg") + (send el set-innerHTML! (list 'span (tr 'stopped)))) + ((eq? st 'paused) + (set-play-button "buttons/play.svg") + (send el set-innerHTML! (list 'span '((class "blink")) (tr 'paused)))) + ((eq? st 'quit) + (void)) + (else + (warn-rktplayer "Unkown state for update-state ~a" st) + (send el set-innerHTML! (list 'span + '((class "blink")) + (format "~a: ~a" (tr 'unknown-state) st)))) + )) + (set! state st) + ) + ) + + (define/public (update-tabs) + (dbg-rktplayer "playlist = ~a" playlist) + (let* ((tabs (send playlist tab-count)) + (html "") + (tab-el (send this element 'tabs)) + (idx 0) + ) + (while (< idx tabs) + (let ((tab-name (send playlist get-tab-name idx))) + (set! html (string-append + html + (xexpr->string + (list 'span (list (list 'id (format "tab~a" idx)) + '(class "tab")) + tab-name)))) + ) + (set! idx (+ idx 1))) + + (send tab-el set-innerHTML! html) + + (send this bind! "#tabs > span" 'click + (λ (el evt data) + (let* ((tab-id (send el id)) + (tab-idx (string->number (substring (format "~a" tab-id) 3))) + ) + (send this set-tab! tab-idx)))) + + (send this bind! "#tabs > span" 'contextmenu + (λ (el evt data) + (let* ((tab-id (send el id)) + (tab-idx (string->number (substring (format "~a" tab-id) 3))) + ) + (send this tab-context data tab-id tab-idx)))) + + (let ((id (string->symbol (format "tab~a" current-tab)))) + (let ((el (send this element id))) + (send el add-class! 'current)) + ) + ) + ) + + (define/public (tab-context evt tab-id tab-idx) + (let ((items (list + (wv-menu-item 'm-tab-rename (tr 'rename-playlist) #:callback (λ () (send this rename-tab! tab-id tab-idx))) + (wv-menu-item 'm-tab-drop (tr 'remove-playlist) #:callback (λ () (send this drop-tab! tab-id tab-idx))) + (wv-menu-item 'm-tab-add (tr 'add-playlist) #:callback (λ () (send this add-tab))) + ) + ) + ) + + (let* ((mnu (wv-menu 'tab-popup items)) + (clientX (hash-ref evt 'clientX 60)) + (clientY (hash-ref evt 'clientY 60)) + ) + (send this popup-menu! mnu clientX clientY) + ) + ) + ) + + (define/public (log-file! file) + (set log-file file)) + + (define/public (drop-tab! tab-id tab-idx) + (when (= current-tab tab-idx) + (send this stop)) + (send playlist drop-tab! tab-idx) + (send this set-tab! 0) + ) + + (define/public (rename-tab! tab-id tab-idx) + (let* ((inp-id (string->symbol (format "tab-input~a" tab-idx))) + (tab-el-id (string->symbol (format "tab~a" tab-idx))) + (html (list 'input (list (list 'id (format "~a" inp-id)) + (list 'name (format "~a" inp-id)) + '(type "text") + (list 'value (send playlist get-tab-name tab-idx)) + ))) + (tab-el (send this element tab-el-id)) + (unbind-events (λ () + (send this unbind! inp-id 'change) + (send this unbind! inp-id 'blur))) + ) + (send tab-el set-innerHTML! html) + (send this unbind! tab-el-id '(click contextmenu)) + (send this bind! inp-id 'change + (λ (el evt data) + (let ((tab-name (hash-ref data 'value (send playlist get-tab-name tab-idx)))) + (send playlist set-tab-name! tab-idx tab-name) + (unbind-events) + (send this update-tabs)))) + (send this bind! inp-id 'blur + (λ (el evt data) + (unbind-events) + (send this update-tabs))) + (let ((inp-el (send this element inp-id))) + (send inp-el focus!)) + ) + ) + + (define/public (set-tab! tab-idx) + (send this stop) + (set! current-tab tab-idx) + (send playlist load-tab tab-idx) + (send this update-tabs) + (send this update-playlist) + ) + + (define/public (add-tab) + (send playlist add-tab!) + (send this update-tabs)) + + (define (update-audio-info rate channels bits audio-format) + (let ((format-num (λ (x) (if (= x 0) "-" x))) + (format-dec (λ (x) (if (eq? x 'none) "-" x)))) + (send el-bits set-innerHTML! (format "~a ~a" (format-num bits) (tr 'bits))) + (send el-channels set-innerHTML! (format "~a ~a" (format-num channels) (tr 'channels))) + (send el-rate set-innerHTML! (format "~a Hz" (format-num rate))) + (send el-format set-innerHTML! (format "~a" (format-dec audio-format))) + ) + ) + + (define (update-repeat state) + (let ((img (if (eq? state 'no-repeat) + "buttons/repeat-off.svg" + (if (eq? state 'repeat-one) + "buttons/repeat-one.svg" + "buttons/repeat.svg")))) + (let ((el (send this element 'repeat-img))) + (send el set-attr! (list 'src img))) + ) + ) + + (define player #f) + (define dlna-renderers '()) + + (define/public (play-local) + (unless (eq? player #f) + (send player stop) + (send player quit)) + (set! player (new player% + [time-updater update-time] + [track-nr-updater update-track-nr] + [state-updater update-state] + [repeat-updater update-repeat] + [audio-info-cb update-audio-info] + [settings settings] + )) + (unless (eq? playlist #f) + (send player playlist! playlist)) + ) + + (define/public (play-to-dlna renderer-idx) + (let ((renderer (list-ref dlna-renderers renderer-idx))) + (displayln (format "Play to ~a" (car renderer))))) + + (define/public (dlna-query-busy) + (send this message! (tr 'dlna-query-busy) #:clear #t)) + + (define/public (set-dlna-renderers! renderers) + (set! dlna-renderers renderers) + (send this message! (format (tr 'dlna-renderers-count) (length renderers)) #:clear #t) + (send this set-menu! (player-menu renderers (λ (id idx) + (send this connect-menu! id + (λ () + (displayln (format "dlna playback: ~a" idx)) + (send this play-to-dlna idx)))))) + #t) + + (define/public (check-dlna) + (check-dlna-players this)) + + (define inner-html-handlers (make-hash)) + + (define/override (page-loaded oke) + (semaphore-wait initialized) + (semaphore-post initialized) + + (super page-loaded oke) + + (let ((el (send this element 'log-file))) + (send el set-innerHTML! (format "~a" log-file))) + + (ww-connect 'play play-or-pause) + (ww-connect 'stop stop) + (ww-connect 'prev previous-track) + (ww-connect 'next next-track) + (ww-connect 'repeat repeat) + (ww-connect 'volume volume) + (ww-connect 'devtools devtools) + + (set! el-seeker (send this element 'seek)) + (dbg-rktplayer "el-seeker: ~a" (send el-seeker get)) + (let ((seek-reactor (webview-delayed-reactor 0.3 + (λ (percentage) + ;(displayln (format "el-seeker: ~a" percentage)) + (send this seek-to percentage))))) + (send el-seeker on-change! seek-reactor)) + + (set! el-volume (send this element 'volume-range)) + (set! el-vol-perc (send this element 'volume-perc)) + (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))) + #:update (λ (val) + (let ((p (* val val))) + (send el-vol-perc set-innerHTML! (sprintf "%d%" p)) + ))))) + (send el-volume on-change! volume-reactor)) + + + (set! el-library (send this element 'library)) + (set! el-playlist (send this element 'tracks)) + + (set! el-at (send this element 'time)) + (set! el-length (send this element 'totaltime)) + + (set! el-rate (send this element 'rate)) + (set! el-bits (send this element 'bits)) + (set! el-channels (send this element 'channels)) + (set! el-format (send this element 'format)) + + (send this set-menu! (player-menu '() (λ (id idx) #t))) + (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-check-dlna (λ () (send this check-dlna))) + + (dbg-rktplayer "page-loaded, playlist = ~a" playlist) + (send this update-tabs) + (send this update-library) + (send this update-playlist) + + (when (eq? state #f) + (update-audio-info 0 0 0 'none) + (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 this update-volume) + ) + + (define/public (scroll-top id) + (send this run-js + (format + (string-append "{ let el_id = '~a';" + " console.log('id = ' + el_id);" + " let el = document.getElementById(el_id);" + " console.log(el);" + " el.scrollTop = 0;" + "}") + 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))) + (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))))) + (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...") + + )) + ) + ) + + (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 (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 + )))) + + (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 play-remote #f) + (define/public (toggle-remote) + (info-rktplayer "Toggling remote playing") + (set! play-remote (not play-remote)) + ;(displayln (format "player = ~a" player)) + (if play-remote + (send player change-player 'remote + #:host "hans@mahler.thuis.local" + #:basepaths '(("\\\\panderleou\\music" . "/muziek") + ("//panderleou/music" . "/muziek") + )) + (send player change-player 'local)) + (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) + (send this update-playlist) + ) + + (define/public (open-booklet path . is-file*) + (let* ((is-file (if (null? is-file*) #f (eq? (car is-file*) #t))) + (booklet (if is-file path (build-path path "booklet.pdf")))) + (dbg-rktplayer "Open booklet ~a" booklet) + (open-app booklet))) + + (define/public (open-folder path) + (dbg-rktplayer "path: ~a" path) + (open-file-manager path)) + ;(let ((folder (if (file-exists? path) (path-only path) path))) + ; (open-file-manager folder))) + + (define/public (play-or-pause) + (cond + ((eq? state 'playing) + (send player pause!)) + ((eq? state 'paused) + (send player play!)) + (else + (play-track 0)) + ) + ) + + (define/public (stop) + (dbg-rktplayer "Stop") + (send player stop) + (update-track-nr #f)) + + (define/public (play-track idx) + (unless (= (send playlist length) 0) + (send player play-track idx))) + + (define/public (pause) + (send player pause-unpause)) + + (define/public (next-track) + (send player next) + ) + + (define/public (previous-track) + (send player previous) + ) + + (define/public (repeat) + (let ((r (send player get-repeat))) + (let ((nr (cond + ((eq? r 'no-repeat) 'repeat-all) + ((eq? r 'repeat-all) 'repeat-one) + (else 'no-repeat)))) + (send player repeat! nr) + ) + ) + ) + + (define/public (volume) + (let* ((volume-meter (send this element 'volume-meter)) + (volume-display (send volume-meter display)) + ) + (if (eq? volume-display 'block) + (send volume-meter display 'none) + (begin + (send volume-meter display 'block) + (send el-volume set! + (sqrt (send player get-volume))) + (send el-vol-perc set-innerHTML! + (sprintf "%d%" (send player get-volume)))) + ) + ) + ) + + (define/public (set-volume! percentage) + (send player set-volume! percentage) + (send this update-volume) + ) + + (define/public (seek-to percentage) + (dbg-rktplayer "Seeking to percentage: ~a" percentage) + (send player seek percentage) + ) + + (define/override (quit) + (dbg-rktplayer "Quitting") + (send player quit) + (set! closed #t) + (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]))) + (send dlg show))) + + + (define/public (show-hide) + (let ((st (send this window-state))) + (if (eq? st 'hidden) + (send this present) + (send this hide) + ) + ) + ) + + (define window-state-change-callback (λ () #t)) + + (define/public (set-window-state-change-callback! f) + (set! window-state-change-callback f)) + + (define/override (window-state-changed st) + (window-state-change-callback)) + + (define/override (can-close?) + (show-hide) + #f) + + (begin + (dbg-rktplayer "Initializing local player") + (play-local) + (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)])) + (send player set-list! playlist) + (dbg-rktplayer "playlist = ~a" playlist) + + (semaphore-post initialized) + ) + ) + ) + + diff --git a/gui/rktplayer.html b/gui/rktplayer.html index 56a3f9d..5d94da5 100644 --- a/gui/rktplayer.html +++ b/gui/rktplayer.html @@ -54,6 +54,7 @@ +
diff --git a/player.rkt b/player.rkt index 92b8551..e129f14 100644 --- a/player.rkt +++ b/player.rkt @@ -132,9 +132,12 @@ (clear-music-ids!) ) - (define/public (play playlist*) + (define/public (playlist! playlist*) (check-player) - (set-list! playlist*) + (set-list! playlist*)) + + (define/public (play playlist*) + (send this playlist! playlist*) (send this play-track 0)) (define/public (play-track nr) diff --git a/translate.rkt b/translate.rkt index da6276b..474a824 100644 --- a/translate.rkt +++ b/translate.rkt @@ -199,4 +199,19 @@ ('browse ('en "Browse") ('nl "Bladeren")) + ('dlna-renderers-count + ('en "Found ~a DLNA Players") + ('nl "~a DLNA Spelers gevonden")) + ('dlna-query-busy + ('en "Busy querying DLNA Media Renderers") + ('nl "Bezig DLNA Media Rendeerers op te vragen")) + ('play-local + ('en "Play music on current hardware") + ('nl "Muziek afspelen op huidige hardware")) + ('check-dlna + ('en "Search DLNA Players on network") + ('nl "Zoek DLNA Spelers op het netwerk")) + ('players + ('en "Audio Players") + ('nl "Muziek Spelers")) )