hans/rktplayer
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: hans/rktplayer:voor-refactoring-2026-08-04
Branches Tags
hans/rktplayer:main
hans/rktplayer:voor-refactoring-2026-08-04
..
compare: hans/rktplayer:main
Branches Tags
hans/rktplayer:main
hans/rktplayer:voor-refactoring-2026-08-04

1 Commits
voor-refactoring-2026-08-04 .. main

Author SHA1 Message Date
hans f5fdc38e67 Complete refactoring for rktplayer, in order to make it play on DLNA renderers and also use UpNP media server resources. 2026-08-08 14:29:01 +02:00
69 changed files with 5953 additions and 1647 deletions
Expand all files Collapse all files
.gitignore
+1
View File
@@ -20,3 +20,4 @@ compiled/
/*.bak /*.bak
/gui/*.bak /gui/*.bak
/gui/html/*.bak
AGENTS.md
+10
View File
@@ -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.
dlna-player.rkt
-373
View File
@@ -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"))))
dlna.rkt
-40
View File
@@ -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))
)
)
)
gui.rkt → gui/gui.rkt
+573 -209
View File
@@ -6,15 +6,20 @@
racket-sprintf racket-sprintf
open-app open-app
xml xml
"utils.rkt" "../misc/utils.rkt"
"music-library.rkt"
"translate.rkt" "translate.rkt"
"playlist.rkt" "../play/playlist.rkt"
"player.rkt" "../play/playlist-gui.rkt"
"dlna-player.rkt" "../play/base/player.rkt"
"../play/dlna-player.rkt"
"settings.rkt" "settings.rkt"
"libraries.rkt" "../library/libraries-config.rkt"
"dlna.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 (provide
@@ -22,15 +27,30 @@
rktplayer% 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 (define player-menu
(λ (renderers connector) (λ (renderers libraries current-player-id current-library-id
player-connector library-connector)
(wv-menu 'main-menu (wv-menu 'main-menu
(wv-menu-item 'm-file (tr 'file) (wv-menu-item 'm-file (tr 'file)
#:submenu (wv-menu 'file-menu #: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-settings (tr 'settings))
(wv-menu-item 'm-quit (tr 'quit) #:separator #t) (wv-menu-item 'm-quit (tr 'quit) #:separator #t)
)) ))
@@ -38,7 +58,11 @@
#:submenu (apply wv-menu #:submenu (apply wv-menu
(append (append
(list 'dlna-menu (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))) (wv-menu-item 'm-check-dlna (tr 'check-dlna)))
(let ((rndr-idx 0)) (let ((rndr-idx 0))
(map (λ (r) (map (λ (r)
@@ -46,12 +70,38 @@
(id (string->symbol (id (string->symbol
(format "m-renderer-~a" idx)))) (format "m-renderer-~a" idx))))
(set! rndr-idx (+ rndr-idx 1)) (set! rndr-idx (+ rndr-idx 1))
(connector id idx) (player-connector id idx)
(wv-menu-item id (car r) #:separator (= idx 0)))) (wv-menu-item
renderers)))) 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% (define rktplayer%
(class wv-window% (class wv-window%
(init-field [log-file #f]) (init-field [log-file #f])
@@ -59,7 +109,7 @@
(super-new (super-new
[html-path "rktplayer.html"] [html-path "rktplayer.html"]
[title "Racket Music Player"] [title application-title]
[icon (build-path rkt-gui-dir "rktplayer.png")] [icon (build-path rkt-gui-dir "rktplayer.png")]
[quit-on-close #f] [quit-on-close #f]
) )
@@ -72,10 +122,12 @@
(define el-vol-perc #f) (define el-vol-perc #f)
(define el-library #f) (define el-library #f)
(define el-playlist #f) (define el-playlist #f)
(define playlist-gui #f)
(define el-at #f) (define el-at #f)
(define el-length #f) (define el-length #f)
(define el-rate #f) (define el-rate #f)
(define el-format #f) (define el-format #f)
(define el-source #f)
(define el-channels #f) (define el-channels #f)
(define el-bits #f) (define el-bits #f)
(define el-message #f) (define el-message #f)
@@ -83,19 +135,22 @@
(define current-tab 0) (define current-tab 0)
(define music-library (define library-factory
(let* ((libs (new libraries% [settings cfg])) (get-library-factory))
(lib (send libs current-library))
(dir (if (eq? lib #f) (define libraries-config
(find-system-path 'home-dir) (send library-factory
(send lib get-local-path))) get-libraries-config))
(path (format "~a" dir)))
(when (eq? (system-type 'os) 'windows) (define library-browser #f)
(set! path (string-replace path "/" "\\")))
(dbg-rktplayer "music-library: ~a" path) (define library-items
path)) (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 playlist #f)
(define current-at-seconds 0) (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) (when (eq? el-message #f)
(set! el-message (send this element 'message))) (set! el-message (send this element 'message)))
(unless (eq? el-message #f) (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 (when clear
(void (void
(thread (λ () (thread (λ ()
@@ -151,9 +215,109 @@
(send this message! "" #:clear #f))))) (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 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) (define (update-track-nr nr)
(when (eq? nr #f)
(update-track-source! #f))
(unless (or (eq? playlist #f) (unless (or (eq? playlist #f)
(= (send playlist length) 0)) (= (send playlist length) 0))
(dbg-rktplayer "update-track-nr ~a" nr) (dbg-rktplayer "update-track-nr ~a" nr)
@@ -167,6 +331,11 @@
(send el remove-class! "current"))) (send el remove-class! "current")))
(set! current-track-nr nr) (set! current-track-nr nr)
(update-track-source!
(and current-track-nr
(send playlist
track
current-track-nr)))
(dbg-rktplayer "Adding current") (dbg-rktplayer "Adding current")
(unless (eq? current-track-nr #f) (unless (eq? current-track-nr #f)
@@ -189,16 +358,6 @@
(current-milliseconds)))) (current-milliseconds))))
(dbg-rktplayer "Html = ~a" html) (dbg-rktplayer "Html = ~a" html)
(send el set-innerHTML! 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) ((eq? st 'paused)
(set-play-button "buttons/play.svg") (set-play-button "buttons/play.svg")
(send el set-innerHTML! (list 'span '((class "blink")) (tr 'paused)))) (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) ((eq? st 'quit)
(void)) (void))
(else (else
@@ -377,7 +541,113 @@
) )
(define player #f) (define player #f)
(define active-player-id 'm-play-local)
(define dlna-renderers '()) (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) (define/public (play-local)
(unless (eq? player #f) (unless (eq? player #f)
@@ -391,13 +661,18 @@
[audio-info-cb update-audio-info] [audio-info-cb update-audio-info]
[settings settings] [settings settings]
)) ))
(set! active-player-id 'm-play-local)
(unless (eq? playlist #f) (unless (eq? playlist #f)
(send player playlist! playlist)) (send player playlist! playlist))
) )
(define/public (play-to-dlna renderer-idx) (define/public (play-to-dlna renderer-idx)
(let* ((entry (list-ref dlna-renderers renderer-idx)) (let ((renderer
(renderer (cadr entry))) (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) (unless (eq? player #f)
(send player stop) (send player stop)
(send player quit)) (send player quit))
@@ -407,11 +682,35 @@
[time-updater update-time] [time-updater update-time]
[track-nr-updater update-track-nr] [track-nr-updater update-track-nr]
[state-updater update-state] [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] [repeat-updater update-repeat]
[audio-info-cb update-audio-info] [audio-info-cb update-audio-info]
[settings settings])) [settings settings]))
(set! active-player-id
(string->symbol
(format "m-renderer-~a" renderer-idx)))
(unless (eq? playlist #f) (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) (define/public (dlna-query-busy)
(send this message! (tr 'dlna-query-busy) #:clear #t)) (send this message! (tr 'dlna-query-busy) #:clear #t))
@@ -419,21 +718,13 @@
(define/public (set-dlna-renderers! renderers) (define/public (set-dlna-renderers! renderers)
(set! dlna-renderers renderers) (set! dlna-renderers renderers)
(send this message! (format (tr 'dlna-renderers-count) (length renderers)) #:clear #t) (send this message! (format (tr 'dlna-renderers-count) (length renderers)) #:clear #t)
(let ((connector-list '())) (send this update-main-menu)
(send this set-menu! (player-menu renderers (λ (id idx) #t)
(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) (define/public (check-dlna)
(check-dlna-players this)) (check-dlna-players
this
renderer-preferences))
(define inner-html-handlers (make-hash)) (define inner-html-handlers (make-hash))
@@ -467,17 +758,32 @@
(dbg-rktplayer "el-volume: ~a" (send el-volume get)) (dbg-rktplayer "el-volume: ~a" (send el-volume get))
(let ((volume-reactor (webview-delayed-reactor 1.0 (let ((volume-reactor (webview-delayed-reactor 1.0
(λ (volume-range) (λ (volume-range)
(let ((percentage (* volume-range volume-range))) (send this set-volume! volume-range))
(send this set-volume! percentage)))
#:update (λ (val) #:update (λ (val)
(let ((p (* val val))) (send el-vol-perc
(send el-vol-perc set-innerHTML! (sprintf "%d%" p)) set-innerHTML!
))))) (sprintf "%d%" val))))))
(send el-volume on-change! volume-reactor)) (send el-volume on-change! volume-reactor))
(set! el-library (send this element 'library)) (set! el-library (send this element 'library))
(set! el-playlist (send this element 'tracks)) (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-at (send this element 'time))
(set! el-length (send this element 'totaltime)) (set! el-length (send this element 'totaltime))
@@ -486,13 +792,19 @@
(set! el-bits (send this element 'bits)) (set! el-bits (send this element 'bits))
(set! el-channels (send this element 'channels)) (set! el-channels (send this element 'channels))
(set! el-format (send this element 'format)) (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-quit (λ () (send this quit)))
(send this connect-menu! 'm-select-library-dir (λ () (send this select-library))) (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-settings (λ () (send this settings-dlg)))
(send this connect-menu! 'm-add-tab (λ () (send this add-tab))) (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))) (send this connect-menu! 'm-check-dlna (λ () (send this check-dlna)))
(dbg-rktplayer "page-loaded, playlist = ~a" playlist) (dbg-rktplayer "page-loaded, playlist = ~a" playlist)
@@ -505,65 +817,11 @@
(update-state 'stopped)) (update-state 'stopped))
) )
(define el-dragged #f)
(define/public (update-playlist) (define/public (update-playlist)
(let* ((html (send playlist to-html)) (send playlist-gui
(result (send el-playlist set-innerHTML! html)) update!
) playlist
(dbg-rktplayer "result: ~a" result) current-track-nr)
(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) (send this update-volume)
) )
@@ -578,83 +836,169 @@
"}") "}")
id))) id)))
(define/public (update-library) (define/private (render-library! browser items can-go-up?)
(when (eq? current-music-path #f) (hash-clear! library-items)
(set! current-music-path music-library)) (let ((rows '()))
(let* ((nr 0) (when browser
(l (filter (λ (r) (music-lib-relevant? (cadr r))) (let ((item-nr 0))
(map (λ (e) (set! rows
(set! nr (+ nr 1)) (map
(list (format "row-~a" nr) (build-path current-music-path e) (format "path-~a" nr))) (lambda (item)
(if (directory-exists? current-music-path) (let ((item-id (format "media-item-~a" item-nr)))
(directory-list current-music-path) (set! item-nr (+ item-nr 1))
'()))))) (hash-set! library-items item-id item)
(unless (path-equal? current-music-path music-library) (list (format "row-~a" item-nr)
(set! l (cons (list "lib-up" "↰" "lib-up") l)) item-id
) (send item get-title))))
(let ((html (mktable l 'music-library library-formatter))) 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))) (let ((result (send el-library set-innerHTML! html)))
(dbg-rktplayer "set-innerHTML!: ~a" result) (dbg-rktplayer "set-innerHTML!: ~a" result)
(send this scroll-top 'library) (send this scroll-top 'library)
(dbg-rktplayer "Binding...")
(send this bind! "td.library-entry" 'click (send this bind! "td.library-entry" 'click
(λ (el evt data) (lambda (el evt data)
(dbg-rktplayer "~a ~a" evt data) (let ((item-id (send el attr 'item-id)))
(dbg-rktplayer "id:~a, file:~a" (send el attr 'id) (send el attr 'file)) (cond
(let ((path (send el attr 'file))) ((equal? item-id "lib-up")
(unless (eq? path #f) (send browser go-up!)
(send this path-choosen path))))) (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 (send this bind! "td.library-entry" 'contextmenu
(λ (el evt data) (lambda (el evt data)
(dbg-rktplayer "~a ~a" evt data) (let ((item-id (send el attr 'item-id)))
(let ((path (send el attr 'file))) (when (hash-has-key? library-items item-id)
(unless (eq? path #f) (send this
(send this context-for-path data path))) context-for-media-item
)) data
(dbg-rktplayer "Done...") (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) (define/public (update-library)
(let ((path-part (if (equal? path "↰") ".." (format "~a" path)))) (set! library-update-request (+ library-update-request 1))
(let ((npath (if (string=? path-part "..") (let ((request library-update-request)
(build-path current-music-path path-part) (browser library-browser))
path))) (hash-clear! library-items)
(when (directory-exists? npath) (if browser
(set! current-music-path (normalize-path npath)) (begin
(send this update-library) (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) (define/private (media-item-containing-folder item)
(let ((items (list (let ((track (send item get-track)))
(wv-menu-item 'm-play-this (tr 'play-this) #:callback (λ () (send this play-path path)))))) (if track
(when (file-exists? path) (let* ((resource (send track get-resource))
(set! items (append items (file
(list (and resource
(wv-menu-item 'm-add-this (tr 'add-this) #:callback (λ () (send this add-path path))))))) (is-a? resource
(when (file-exists? (build-path path "booklet.pdf")) media-resource-file%)
(set! items (append items (send resource get-file))))
(list (and file
(wv-menu-item 'm-booklet (tr 'open-booklet) #:callback (λ () (send this open-booklet path))) ;; todo check if pdf file exists (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 (define/public (context-for-media-item evt item)
(list (let* ((track (send item get-track))
(wv-menu-item 'm-folder (tr 'open-containing-folder) #:callback (λ () (send this open-folder path))) (containing-folder
))) (media-item-containing-folder item))
(let* ((mnu (wv-menu 'library-popup items)) (items
(clientX (hash-ref evt 'clientX 60)) (list
(clientY (hash-ref evt 'clientY 60)) (wv-menu-item
) 'm-play-this
(send this popup-menu! mnu clientX clientY) (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 play-remote #f)
(define/public (toggle-remote) (define/public (toggle-remote)
@@ -671,22 +1015,18 @@
(info-rktplayer "Playing remote: ~a" play-remote) (info-rktplayer "Playing remote: ~a" play-remote)
) )
(define/public (play-path path) (define/public (play-media-item item)
(dbg-rktplayer "Playing ~a" path) (set! current-track-nr #f)
(let ((pl (new playlist% [start-map path] [settings (send settings clone 'playlists)] [id current-tab]))) (send playlist replace-with-media-item! item)
(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) (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*) (define/public (open-booklet path . is-file*)
(let* ((is-file (if (null? is-file*) #f (eq? (car is-file*) #t))) (let* ((is-file (if (null? is-file*) #f (eq? (car is-file*) #t)))
@@ -752,7 +1092,7 @@
(begin (begin
(send volume-meter display 'block) (send volume-meter display 'block)
(send el-volume set! (send el-volume set!
(sqrt (send player get-volume))) (send player get-volume))
(send el-vol-perc set-innerHTML! (send el-vol-perc set-innerHTML!
(sprintf "%d%" (send player get-volume)))) (sprintf "%d%" (send player get-volume))))
) )
@@ -771,18 +1111,37 @@
(define/override (quit) (define/override (quit)
(dbg-rktplayer "Quitting") (dbg-rktplayer "Quitting")
(send player quit)
(set! closed #t) (set! closed #t)
(when playlist
(send playlist stop-cache!))
(send player quit)
(send this close) (send this close)
(dbg-rktplayer "Calling super -> quit") (dbg-rktplayer "Calling super -> quit")
(super quit) (super quit)
) )
(define/public (settings-dlg) (define/public (settings-dlg)
(let ((dlg (new settings% [settings (send settings clone 'settings-dlg)] (let ((dlg (new settings%
[parent this]))) [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))) (send dlg show)))
(define/public (select-library)
(send this settings-dlg))
(define/public (show-hide) (define/public (show-hide)
(let ((st (send this window-state))) (let ((st (send this window-state)))
@@ -808,11 +1167,16 @@
(begin (begin
(dbg-rktplayer "Initializing local player") (dbg-rktplayer "Initializing local player")
(play-local) (play-local)
(initialize-library-browser!)
(dbg-rktplayer "Initalizing gui") (dbg-rktplayer "Initalizing gui")
(dbg-rktplayer "ICON: ~a" (get-field icon this)) (dbg-rktplayer "ICON: ~a" (get-field icon this))
(let ((lang (send settings get 'lang 'en))) (let ((lang (send settings get 'lang 'en)))
(dbg-rktplayer "RktPlayer started, current language: ~a" lang)) (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) (send player set-list! playlist)
(dbg-rktplayer "playlist = ~a" playlist) (dbg-rktplayer "playlist = ~a" playlist)
gui/buttons/next.svg → gui/html/buttons/next.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 893 B

After

Width:  |  Height:  |  Size: 894 B

gui/buttons/pause.svg → gui/html/buttons/pause.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 849 B

After

Width:  |  Height:  |  Size: 846 B

gui/buttons/play.svg → gui/html/buttons/play.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.8 KiB

After

Width:  |  Height:  |  Size: 1.8 KiB

gui/buttons/previous.svg → gui/html/buttons/previous.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 903 B

After

Width:  |  Height:  |  Size: 904 B

gui/buttons/repeat-off.svg → gui/html/buttons/repeat-off.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 2.1 KiB

After

Width:  |  Height:  |  Size: 2.1 KiB

gui/buttons/repeat-one.svg → gui/html/buttons/repeat-one.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.5 KiB

After

Width:  |  Height:  |  Size: 1.5 KiB

gui/buttons/repeat.svg → gui/html/buttons/repeat.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.2 KiB

After

Width:  |  Height:  |  Size: 1.2 KiB

gui/buttons/stop.svg → gui/html/buttons/stop.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.7 KiB

After

Width:  |  Height:  |  Size: 1.7 KiB

gui/buttons/volume-high.svg → gui/html/buttons/volume-high.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.3 KiB

After

Width:  |  Height:  |  Size: 1.3 KiB

gui/buttons/volume-low.svg → gui/html/buttons/volume-low.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.3 KiB

After

Width:  |  Height:  |  Size: 1.3 KiB

gui/buttons/volume-mute.svg → gui/html/buttons/volume-mute.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.2 KiB

After

Width:  |  Height:  |  Size: 1.2 KiB

gui/devtools.svg → gui/html/devtools.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 3.9 KiB

After

Width:  |  Height:  |  Size: 3.9 KiB

gui/favicon.ico → gui/html/favicon.ico
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 92 KiB

After

Width:  |  Height:  |  Size: 92 KiB

gui/html/library-dialog.html
+56
View File
@@ -0,0 +1,56 @@
<!DOCTYPE html>
<html>
<head>
<link rel="stylesheet" href="styles.css" />
<meta charset="UTF-8" />
<title>RktPlayer - A music player - library entry</title>
</head>
<body>
<div class="pane">
<div class="keyval">
<label for="selected-library-kind" id="lbl-kind">Kind:</label>
<select id="selected-library-kind"></select>
</div>
<hr />
<div class="keyval">
<label for="name" id="lbl-name">Name:</label>
<input type="text" id="name" />
</div>
<div id="filesystem-fields">
<div class="keyval">
<label for="local-path" id="lbl-local-path">Local path:</label>
<div class="file-box">
<input id="local-path" type="text" />
<button id="browse">Browse</button>
</div>
</div>
</div>
<div id="media-server-fields" style="display: none">
<div class="keyval">
<label for="selected-media-server" id="lbl-media-server">Media server:</label>
<div class="file-box">
<select id="selected-media-server"></select>
<button id="refresh-media-servers">Refresh</button>
</div>
</div>
<div class="keyval">
<label for="selected-media-server-container" id="lbl-media-server-root">Start point:</label>
<div class="file-box">
<span id="media-server-root"></span>
<button id="media-server-root-up">Up</button>
<select id="selected-media-server-container"></select>
</div>
</div>
<div class="keyval">
<label for="media-server-item-limit" id="lbl-media-server-item-limit">Maximum items:</label>
<input id="media-server-item-limit" type="number" min="1" />
</div>
</div>
</div>
<div class="button-box">
<button id="ok">OK</button>
<button id="cancel">Cancel</button>
<button id="dev">devtools</button>
</div>
</body>
</html>
gui/menu.js → gui/html/menu.js
View File
gui/rktplayer.html → gui/html/rktplayer.html
+2 -1
View File
@@ -22,7 +22,7 @@
<img id="volume-img" src="buttons/volume-high.svg" /> <img id="volume-img" src="buttons/volume-high.svg" />
<div id="volume-meter" class="volume-meter"> <div id="volume-meter" class="volume-meter">
<div class="status"><span class="info" id="volume-perc"></span></div> <div class="status"><span class="info" id="volume-perc"></span></div>
<input type="range" min="0" max="13" value="10" class="v-slider" id="volume-range" step="0.1" /> <input type="range" min="0" max="100" value="50" class="v-slider" id="volume-range" step="1" />
</div> </div>
</button> </button>
</div> </div>
@@ -53,6 +53,7 @@
<span class="info" id="rate"></span> <span class="info" id="rate"></span>
<span class="info" id="channels"></span> <span class="info" id="channels"></span>
<span class="info" id="format"></span> <span class="info" id="format"></span>
<span class="info" id="source"></span>
<span class="info" id="paused"></span> <span class="info" id="paused"></span>
<span class="info" id="message"></span> <span class="info" id="message"></span>
<div class="right"> <div class="right">
gui/rktplayer.png → gui/html/rktplayer.png
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 60 KiB

After

Width:  |  Height:  |  Size: 60 KiB

gui/rktplayer.svg → gui/html/rktplayer.svg
View File
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.2 KiB

After

Width:  |  Height:  |  Size: 4.2 KiB

gui/settings.html → gui/html/settings.html
+17 -1
View File
@@ -16,7 +16,7 @@
<hr /> <hr />
<table class="libraries"> <table class="libraries">
<thead id="lib-head"> <thead id="lib-head">
<tr><th id="lbl-name"></th><th id="lbl-local-path"></th><th id="lbl-host"></th><th id="lbl-prefixes"></th></tr> <tr><th id="lbl-name"></th><th id="lbl-kind"></th><th id="lbl-local-path"></th><th id="lbl-host"></th></tr>
</thead> </thead>
<tbody id="lib-body"> <tbody id="lib-body">
</tbody> </tbody>
@@ -26,6 +26,22 @@
<button id="edit">Edit Library</button> <button id="edit">Edit Library</button>
<button id="remove">Remove Library</button> <button id="remove">Remove Library</button>
</div> </div>
<hr />
<div class="button-box">
<button id="clear-cache">Clear downloaded tracks</button>
</div>
<hr />
<label id="lbl-renderers">Audio Players</label>
<table class="renderers">
<thead>
<tr>
<th id="lbl-renderer-name">Name</th>
<th id="lbl-volume-curve">Logarithmic volume</th>
</tr>
</thead>
<tbody id="renderer-body">
</tbody>
</table>
</div> </div>
<div class="button-box"> <div class="button-box">
<button id="ok">OK</button> <button id="ok">OK</button>
gui/styles.css → gui/html/styles.css
+21 -2
View File
@@ -273,12 +273,14 @@ table.tracks td.title, table.tracks td.album {
} }
table.tracks tr, table.tracks td, 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; cursor: default;
user-select: none; 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; background: #e0e0e0;
color: black; color: black;
transition: all 0.5s ease-in; transition: all 0.5s ease-in;
@@ -296,6 +298,18 @@ table.libraries tbody tr.current {
color: #f3961e; 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 { .album-art .content img {
width: auto; width: auto;
height: calc(100% - 20px); height: calc(100% - 20px);
@@ -388,6 +402,11 @@ input.v-slider {
animation: blink 3s infinite both; animation: blink 3s infinite both;
} }
.error {
color: #d60000;
font-weight: bold;
}
@keyframes blink { @keyframes blink {
0%, 0%,
50%, 50%,
gui/library-dialog.html
-41
View File
@@ -1,41 +0,0 @@
<!DOCTYPE html>
<html>
<head>
<link rel="stylesheet" href="styles.css" />
<meta charset="UTF-8" />
<title>RktPlayer - A music player - library entry</title>
</head>
<body>
<div class="pane">
<div class="keyval">
<label for="kind" id="lbl-kind">Action:</label>
<span id="kind">Action</span>
</div>
<hr />
<div class="keyval">
<label for="name" id="lbl-name">Name:</label>
<input type="text" id="name" />
</div>
<div class="keyval">
<label for="local-path" id="lbl-local-path">Local path:</label>
<div class="file-box">
<input id="local-path" type="text" />
<button id="browse">Browse</button>
</div>
</div>
<div class="keyval">
<label for="host" id="lbl-host">Host:</label>
<input type="text" id="host" />
</div>
<div class="keyval">
<label for="prefixes" id="lbl-prefixes">Prefixes:</label>
<textarea type="text" id="prefixes"></textarea>
</div>
</div>
<div class="button-box">
<button id="ok">OK</button>
<button id="cancel">Cancel</button>
<button id="dev">devtools</button>
</div>
</body>
</html>
gui/settings.rkt
+800
View File
@@ -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)
)
)
translate.rkt → gui/translate.rkt
+77 -2
View File
@@ -148,6 +148,9 @@
('paused ('paused
('en "paused") ('en "paused")
('nl "gepauzeerd")) ('nl "gepauzeerd"))
('starting
('en "starting")
('nl "starten"))
('unknown-state ('unknown-state
('en "Unknown state") ('en "Unknown state")
('nl "Onbekende status")) ('nl "Onbekende status"))
@@ -184,6 +187,36 @@
('bits ('bits
('en "bits") ('en "bits")
('nl "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 ('play
('en "Play") ('en "Play")
('nl "Afspelen")) ('nl "Afspelen"))
@@ -212,6 +245,48 @@
('en "Search DLNA Players on network") ('en "Search DLNA Players on network")
('nl "Zoek DLNA Spelers op het netwerk")) ('nl "Zoek DLNA Spelers op het netwerk"))
('players ('players
('en "Audio Players") ('en "Audio Players")
('nl "Muziek Spelers")) ('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"))
) )
tray.rkt → gui/tray.rkt
+2 -2
View File
@@ -3,12 +3,12 @@
(require racket-webview (require racket-webview
racket/runtime-path racket/runtime-path
"translate.rkt" "translate.rkt"
"utils.rkt" "../misc/utils.rkt"
) )
(provide rktplayer-tray%) (provide rktplayer-tray%)
(define-runtime-path rkt-gui-dir "gui") (define-runtime-path rkt-gui-dir "html")
(define rktplayer-tray% (define rktplayer-tray%
(class wv-tray% (class wv-tray%
info.rkt
+5 -3
View File
@@ -2,7 +2,7 @@
(define pkg-authors '(hnmdijkema)) (define pkg-authors '(hnmdijkema))
(define version "0.1.1") (define version "0.1.2")
(define license 'MIT) (define license 'MIT)
(define collection "rktplayer") (define collection "rktplayer")
(define pkg-desc "rktplayer - A music player written in racket") (define pkg-desc "rktplayer - A music player written in racket")
@@ -12,6 +12,10 @@
'("racket/gui" "racket/base" "racket" '("racket/gui" "racket/base" "racket"
"finalizer" "draw-lib" "net-lib" "finalizer" "draw-lib" "net-lib"
"simple-log" "simple-ini" "racket-sprintf" "simple-log" "simple-ini" "racket-sprintf"
"racket-mimetypes"
"racket-upnp"
"racket-sonos"
"racket-audio-dlna"
"early-return" "let-assert" "early-return" "let-assert"
"uni-channel" "port-channel" "uni-channel" "port-channel"
"rackunit-lib" "rackunit-lib"
@@ -26,5 +30,3 @@
)) ))
(define test-omit-paths 'all) (define test-omit-paths 'all)
libraries.rkt
-125
View File
@@ -1,125 +0,0 @@
#lang racket/base
(require racket/class
"utils.rkt"
)
(provide libraries%
library%
)
(define library%
(class object%
(init-field [id (new-id)] [name ""] [local-path ""]
[host ""] [prefixes ""] [current #f])
(super-new)
(define/public (get-id) id)
(define/public (get-name) name)
(define/public (get-local-path) local-path)
(define/public (get-host) host)
(define/public (get-prefixes) prefixes)
(define/public (is-current?) current)
(define/public (get-current) current)
(define/public (set-current! c) (set! current c))
(define/public (->list)
(list id name local-path host prefixes current))
))
(define libraries%
(class object%
(init-field [settings settings])
(super-new)
(define libs #f)
(define cfg (send settings clone 'settings))
(define (to-library e)
(let ((f (lambda (id n lp h p . c)
(let ((cc (if (null? c) #f (car c))))
(new library% [id id]
[name n] [local-path lp]
[host h] [prefixes p] [current cc])
))))
(apply f e)
)
)
(define (from-library l)
(send l ->list))
(define/public (libraries)
(when (eq? libs #f)
(let ((cfg-libs (send cfg get 'libraries '())))
(dbg-rktplayer "libraries from ini: ~a" cfg-libs)
(set! libs (sort (map to-library cfg-libs)
(lambda (a b)
(string<? (send a get-name) (send b get-name)))))
(dbg-rktplayer "libs: ~a" (map (λ (x) (list (send x get-id) (send x get-name))) libs))
))
libs)
(define/public (set-libraries! libs*)
(send cfg set! 'libraries (map from-library libs*))
(set! libs #f))
(define/public (count)
(length (send this libraries)))
(define/public (library-id idx)
(let ((libs (send this libraries)))
(if (and (>= idx 0) (< idx (length libs)))
(send (list-ref libs idx) get-id)
#f)))
(define/public (get-library id)
(let ((libs (send this libraries)))
(letrec ((f (λ (libs)
(if (null? libs)
#f
(let* ((lib (car libs))
(lib-id (send lib get-id)))
(dbg-rktplayer "symbol? lib-id: ~a, lib-id: ~a (~a) eq? ~a" (symbol? lib-id) lib-id (send lib get-name) id)
(if (eq? lib-id id)
lib
(f (cdr libs))))))))
(f libs))))
(define/public (remove-library id)
(let ((libs (send this libraries)))
(send this set-libraries! (filter (λ (lib)
(not (eq? (send lib get-id) id)))
libs))))
(define/public (add-library l)
(let ((libs (send this libraries)))
(send this set-libraries! (cons l libs))
(set! libs #f)
(send l get-id)))
(define/public (update-library l)
(let ((libs (send this libraries))
(id (send l get-id)))
(send this set-libraries! (map (λ (lib)
(if (eq? (send lib get-id) id)
l
lib))
libs))))
(define/public (current-library)
(letrec ((f (lambda (libs)
(if (null? libs)
(if (= (send this count) 0)
#f (send this get-library
(send this library-id 0)))
(let ((l (car libs)))
(if (send l is-current?)
l
(f (cdr libs))))))
))
(f (send this libraries))))
))
library/base/booklet-provider.rkt
+12
View File
@@ -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)))
library/base/image-provider.rkt
+13
View File
@@ -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)))
library/base/media-container.rkt
+52
View File
@@ -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))
library/base/media-item.rkt
+59
View File
@@ -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]))))
library/base/media-library.rkt
+51
View File
@@ -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)))
library/base/media-resource.rkt
+97
View File
@@ -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?)))
library/base/tag-data-provider.rkt
+10
View File
@@ -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)))
library/base/track.rkt
+205
View File
@@ -0,0 +1,205 @@
#lang racket/base
(require racket/class
"booklet-provider.rkt"
"image-provider.rkt"
"media-item.rkt"
"media-resource.rkt"
"tag-data-provider.rkt"
"../track-tag-data.rkt"
"../../misc/utils.rkt")
(provide track<%>
track%)
(define track<%>
(interface ((class->interface media-item%))
get-title
get-artist
get-album
get-number
get-length
get-resource
get-music-library-factory-id
get-track-factory-id
get-track-relive-info
has-image?
image->file
image->mimetype
has-booklet?
booklet-file
track<
->log))
(define next-track-id
0)
(define (new-track-id)
(set! next-track-id (+ next-track-id 1))
(when (> next-track-id 10000000)
(set! next-track-id 1))
next-track-id)
(define track%
(class* media-item% (track<%>)
(init
tag-data-provider
image-provider
booklet-provider
resource
[id #f]
[music-library-factory-id #f]
[track-factory-id #f]
[track-relive-info #f])
(check/c* track%
(tag-data-provider
(is-a?/c tag-data-provider%))
(image-provider
(is-a?/c image-provider%))
(booklet-provider
(is-a?/c booklet-provider%))
(resource
(is-a?/c media-resource%)))
(define the-tag-data-provider
tag-data-provider)
(define the-image-provider
image-provider)
(define the-booklet-provider
booklet-provider)
(define the-resource
resource)
(define the-music-library-factory-id
music-library-factory-id)
(define the-track-factory-id
track-factory-id)
(define the-track-relive-info
track-relive-info)
(define/private (get-tag-data)
(send the-tag-data-provider get-tag-data))
(define/public (get-title)
(track-tag-data-title (get-tag-data)))
(define/public (get-artist)
(track-tag-data-artist (get-tag-data)))
(define/public (get-album)
(track-tag-data-album (get-tag-data)))
(define/public (get-number)
(track-tag-data-number (get-tag-data)))
(define/public (get-length)
(track-tag-data-length (get-tag-data)))
(define/public (get-resource)
the-resource)
(define/public (get-music-library-factory-id)
the-music-library-factory-id)
(define/public (get-track-factory-id)
the-track-factory-id)
(define/public (get-track-relive-info)
the-track-relive-info)
(define/public (has-image?)
(send the-image-provider has-image?))
(define/public (image->file target-file)
(send the-image-provider image->file target-file))
(define/public (image->mimetype)
(send the-image-provider image->mimetype))
(define/public (has-booklet?)
(send the-booklet-provider has-booklet?))
(define/public (booklet-file)
(send the-booklet-provider booklet-file))
(define/public (track< other-track)
(if (string-ci<? (send this get-album)
(send other-track get-album))
#t
(and (string-ci=? (send this get-album)
(send other-track get-album))
(< (send this get-number)
(send other-track get-number)))))
(define/public (->log)
(info-rktplayer "~a - ~a - ~a - ~a"
(send this get-number)
(send this get-title)
(send this get-album)
(send this get-length)))
(super-new
[id (if id id (new-track-id))]
[kind 'track])))
(module+ test
(require rackunit)
(define test-tag-data-provider%
(class tag-data-provider%
(define/override (get-tag-data)
(track-tag-data
"Title"
"Artist"
"Album"
2
120))
(super-new)))
(define test-image-provider%
(class image-provider%
(define/override (has-image?) #f)
(define/override (image->file target-file) #f)
(define/override (image->mimetype) 'no-mimetype)
(super-new)))
(define test-booklet-provider%
(class booklet-provider%
(define/override (has-booklet?) #f)
(define/override (booklet-file) #f)
(super-new)))
(define resource
(new media-resource%
[uri "https://example.com/track.flac"]
[mime-type "audio/flac"]
[protocol-info "http-get:*:audio/flac:*"]
[seekable? #t]))
(define track
(new track%
[resource resource]
[tag-data-provider
(new test-tag-data-provider%)]
[image-provider
(new test-image-provider%)]
[booklet-provider
(new test-booklet-provider%)]))
(check-true (is-a? track track%))
(check-true (is-a? track track<%>))
(check-equal? (send track get-kind) 'track)
(check-equal? (send track get-title) "Title")
(check-equal? (send track get-artist) "Artist")
(check-equal? (send track get-album) "Album")
(check-equal? (send track get-number) 2)
(check-equal? (send track get-length) 120)
(check-eq? (send track get-resource) resource)
(check-false (send track has-image?))
(check-false (send track has-booklet?)))
library/libraries-config.rkt
+149
View File
@@ -0,0 +1,149 @@
#lang racket/base
(require racket/class
"library-cfg.rkt"
"library-item.rkt"
"../misc/utils.rkt")
(provide libraries-config%
(all-from-out "library-cfg.rkt")
(all-from-out "library-item.rkt"))
(define libraries-config%
(class object%
(init-field settings)
(define items
#f)
(define revisions
(make-hash))
(define cfg
(send settings clone 'settings))
(define/private (sorted-items value)
(sort value
(lambda (a b)
(string<? (library-item-name a)
(library-item-name b)))))
(define/private (get-items)
(when (eq? items #f)
(let ((stored (send cfg get 'libraries '())))
(dbg-rktplayer "libraries from ini: ~a" stored)
(set! items
(sorted-items
(map store->library-item stored)))))
items)
(define/private (store-items! value)
(let ((new-items (sorted-items value)))
(send cfg
set!
'libraries
(map library-item->store new-items))
(set! items new-items)))
(define/private (increment-revision! id)
(hash-update! revisions id add1 0))
(define/public (libraries)
(map (lambda (item)
(new library-cfg%
[library-cfg-id (library-item-id item)]
[libraries-config this]))
(get-items)))
(define/public (count)
(length (get-items)))
(define/public (library-id idx)
(let ((all-items (get-items)))
(if (and (>= idx 0)
(< idx (length all-items)))
(library-item-id (list-ref all-items idx))
#f)))
(define/public (get-item id)
(check/c libraries-config% get-item id symbol?)
(findf (lambda (item)
(eq? (library-item-id item) id))
(get-items)))
(define/public (get-item-revision id)
(check/c libraries-config% get-item-revision id symbol?)
(hash-ref revisions id 0))
(define/public (get-library id)
(check/c libraries-config% get-library id symbol?)
(and (send this get-item id)
(new library-cfg%
[library-cfg-id id]
[libraries-config this])))
(define/public (remove-library id)
(check/c libraries-config% remove-library id symbol?)
(store-items!
(filter (lambda (item)
(not (eq? (library-item-id item) id)))
(get-items)))
(increment-revision! id))
(define/public (add-library item)
(check/c libraries-config% add-library item library-item?)
(let ((id (library-item-id item)))
(when (send this get-item id)
(raise-arguments-error
'libraries-config%:add-library
"a library with this id already exists"
"id" id))
(store-items! (cons item (get-items)))
(increment-revision! id)
id))
(define/public (update-item! item)
(check/c libraries-config% update-item! item library-item?)
(let* ((id (library-item-id item))
(current-item (send this get-item id)))
(unless current-item
(raise-arguments-error
'libraries-config%:update-item!
"library does not exist"
"id" id))
(unless (and (eq? (library-item-kind current-item)
(library-item-kind item))
(= (library-item-kind-version current-item)
(library-item-kind-version item)))
(raise-arguments-error
'libraries-config%:update-item!
"library kind and kind-version cannot be changed"
"id" id))
(store-items!
(map (lambda (existing)
(if (eq? (library-item-id existing) id)
item
existing))
(get-items)))
(increment-revision! id)
(void)))
(define/public (current-library)
(let ((item
(findf library-item-current
(get-items))))
(if item
(send this get-library
(library-item-id item))
(if (null? (get-items))
#f
(send this get-library
(library-item-id
(car (get-items))))))))
(super-new)))
library/library-browser.rkt
+82
View File
@@ -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!)))
library/library-cfg.rkt
+71
View File
@@ -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)))
library/library-factory.rkt
+108
View File
@@ -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)))
library/library-filesystem.rkt
+66
View File
@@ -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])))
library/library-item.rkt
+74
View File
@@ -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))))
library/library-media-server.rkt
+219
View File
@@ -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])))
library/library-ref.rkt
+7
View File
@@ -0,0 +1,7 @@
#lang racket/base
(provide (struct-out library-ref))
(struct library-ref
(library-id kind version)
#:prefab)
library/mc-filesystem.rkt
+82
View File
@@ -0,0 +1,82 @@
#lang racket/base
(require racket/class
racket-audio
racket/list
racket/path
racket/string
"base/media-container.rkt"
"../misc/utils.rkt")
(provide mc-filesystem%)
(define mc-filesystem%
(class media-container%
(init-field
library
[relative-path '()])
(check/c mc-filesystem% relative-path list?)
(define/private (full-path)
(send library resolve-path relative-path))
(define/private (music-file-name? path)
(let ((file-name
(string-downcase (path->string path))))
(for/or ((extension
(in-list (audio-known-exts?))))
(string-suffix?
file-name
(string-append "." extension)))))
(define/private (item-kind path)
(cond
((directory-exists? path)
(let ((name
(path->string
(file-name-from-path path))))
(and (not (string-prefix? name "."))
'container)))
((music-file-name? path) 'track)
(else #f)))
(define/override (get-title)
(if (null? relative-path)
(send (send library get-cfg) get-name)
(path->string (last relative-path))))
(define/override (get-items)
(let ((path (full-path)))
(if (directory-exists? path)
(for*/list ((entry (in-list
(sort (directory-list path)
path<?)))
(entry-path
(in-value (build-path path entry)))
(kind
(in-value (item-kind entry-path)))
#:when kind)
(let ((entry-relative-path
(append relative-path (list entry))))
(if (eq? kind 'container)
(send library
make-container
entry-relative-path)
(send library
make-track
entry-relative-path))))
'())))
(define/override (get-track-reliver)
(lambda (track-factory-id track-relive-info)
(case track-factory-id
((file)
(send library
make-track
track-relive-info))
(else #f))))
(super-new
[id (cons (send (send library get-cfg) get-id)
relative-path)])))
library/mc-media-server.rkt
+86
View File
@@ -0,0 +1,86 @@
#lang racket/base
(require racket/class
racket/list
racket/string
(prefix-in upnp: racket-upnp)
"base/media-container.rkt"
"../misc/utils.rkt")
(provide mc-media-server%)
(define mc-media-server%
(class media-container%
(init-field
library
container-id
title)
(check/c* mc-media-server%
(library object?)
(container-id string?)
(title string?))
(define/private (audio-item? entry)
(and
(upnp:media-item? entry)
(string? (upnp:media-entry-id entry))
(string? (upnp:media-entry-parent-id entry))
(not
(null?
(upnp:media-item-resources entry)))
(or
(let ((class
(upnp:media-entry-class entry)))
(and class
(string-prefix?
class
"object.item.audioItem")))
(for/or
((resource
(in-list
(upnp:media-item-resources entry))))
(let ((content-type
(upnp:media-resource-content-type
resource)))
(and content-type
(string-prefix?
content-type
"audio/")))))))
(define/override (get-title)
title)
(define/override (get-items)
(filter-map
(lambda (entry)
(cond
((and (upnp:media-container? entry)
(string?
(upnp:media-entry-id entry)))
(send library
make-container
entry))
((audio-item? entry)
(send library
make-track
entry))
(else #f)))
(send library
browse-container
container-id)))
(define/override (get-track-reliver)
(lambda (track-factory-id
track-relive-info)
(send library
relive-track
track-factory-id
track-relive-info)))
(super-new
[id
(cons
(send (send library get-cfg)
get-id)
container-id)])))
library/track-filesystem-providers.rkt
+159
View File
@@ -0,0 +1,159 @@
#lang racket
(require racket-audio
"base/booklet-provider.rkt"
"base/image-provider.rkt"
"base/tag-data-provider.rkt"
"track-tag-data.rkt")
(provide tag-source-filesystem%
tag-data-provider-filesystem%
image-provider-filesystem%
booklet-provider-filesystem%)
(define tag-source-filesystem%
(class object%
(init-field file)
(define tags
#f)
(define loaded?
#f)
(define/private (read-tags)
(if (and file (file-exists? file))
(let* ((source-file
(if (path? file)
(path->string file)
file))
(source-tags (id3-tags source-file)))
(if (tags-valid? source-tags)
source-tags
(let ((temporary-file
(make-temporary-file
"rktplayer-~a"
#:copy-from source-file)))
(let ((temporary-tags
(id3-tags temporary-file)))
(delete-file temporary-file)
temporary-tags))))
#f))
(define/public (get-tags)
(unless loaded?
(set! tags (read-tags))
(set! loaded? #t))
tags)
(super-new)))
(define tag-data-provider-filesystem%
(class tag-data-provider%
(init-field
tag-source
[fallback-data (track-tag-data "" "" "" 0 0)])
(define tag-data
#f)
(define/override (get-tag-data)
(unless tag-data
(let ((tags (send tag-source get-tags)))
(set! tag-data
(if (and tags (tags-valid? tags))
(track-tag-data
(tags-title tags)
(tags-artist tags)
(tags-album tags)
(tags-track tags)
(tags-length tags))
fallback-data))))
tag-data)
(super-new)))
(define image-provider-filesystem%
(class image-provider%
(init-field file tag-source)
(define image-names
'("cover.jpg" "cover.png" "folder.jpg" "folder.png"))
(define/private (image-from-directory)
(and file
(let ((directory (path-only file)))
(for/first ((image-name (in-list image-names))
#:when
(file-exists?
(build-path directory image-name)))
(build-path directory image-name)))))
(define/override (has-image?)
(let ((tags (send tag-source get-tags)))
(or (and tags
(tags-valid? tags)
(not (eq? (tags-picture->ext tags) #f)))
(not (eq? (image-from-directory) #f)))))
(define/override (image->file target-file)
(let* ((target (format "~a" target-file))
(tags (send tag-source get-tags))
(picture-extension
(and tags
(tags-valid? tags)
(tags-picture->ext tags))))
(if picture-extension
(let ((stored-file
(string-append
target
"."
(symbol->string picture-extension))))
(and (tags-picture->file tags stored-file)
stored-file))
(let ((source-file (image-from-directory)))
(and source-file
(let ((stored-file
(string-append
target
(bytes->string/utf-8
(path-get-extension source-file)))))
(copy-file source-file
stored-file
#:exists-ok? #t)
(format "~a" stored-file)))))))
(define/override (image->mimetype)
(let ((tags (send tag-source get-tags)))
(if (and tags
(tags-valid? tags)
(not (eq? (tags-picture->ext tags) #f)))
(tags-picture->mimetype tags)
(let ((source-file (image-from-directory)))
(if source-file
(case (string->symbol
(string-downcase
(bytes->string/utf-8
(path-get-extension source-file))))
((|.jpg| |.jpeg|) "image/jpeg")
((|.png|) "image/png")
(else 'no-mimetype))
'no-mimetype)))))
(super-new)))
(define booklet-provider-filesystem%
(class booklet-provider%
(init-field file)
(define/override (booklet-file)
(and file
(build-path (path-only file)
"booklet.pdf")))
(define/override (has-booklet?)
(let ((booklet (send this booklet-file)))
(and booklet
(file-exists? booklet))))
(super-new)))
library/track-filesystem.rkt
+116
View File
@@ -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)))))
library/track-media-server.rkt
+191
View File
@@ -0,0 +1,191 @@
#lang racket/base
(require net/url
racket-mimetypes/mimetypes
racket/class
racket/list
racket/port
racket/string
(prefix-in upnp: racket-upnp)
"base/booklet-provider.rkt"
"base/image-provider.rkt"
"library-ref.rkt"
"base/media-resource.rkt"
"base/tag-data-provider.rkt"
"track-tag-data.rkt"
"base/track.rkt"
"../misc/utils.rkt")
(provide track-media-server%)
(define tag-data-provider-media-server%
(class tag-data-provider%
(init-field
entry
resource)
(define/override (get-tag-data)
(let ((artists
(upnp:media-item-artists entry)))
(track-tag-data
(upnp:media-entry-title entry)
(cond
((not (null? artists))
(car artists))
((upnp:media-item-creator entry)
(upnp:media-item-creator entry))
(else ""))
(or (upnp:media-item-album entry)
"")
(or
(upnp:media-item-original-track-number
entry)
0)
(or (upnp:media-resource-duration
resource)
0))))
(super-new)))
(define image-provider-media-server%
(class image-provider%
(init-field uri)
(define mime-type
(and uri
(mimetype-for-ext
(regexp-replace
#px"[?#].*$"
uri
"")
#:default
"application/octet-stream")))
(define/private (stored-file target-file)
(let ((extension
(cond
((equal? mime-type "image/jpeg") ".jpg")
((equal? mime-type "image/png") ".png")
(else ""))))
(string-append
(format "~a" target-file)
extension)))
(define/override (has-image?)
(and (string? uri)
(not (string=? uri ""))))
(define/override (image->file target-file)
(and
(send this has-image?)
(with-handlers
((exn:fail?
(lambda (exception)
(warn-rktplayer
"Could not retrieve media-server image: ~a"
(exn-message exception))
#f)))
(let ((file (stored-file target-file)))
(call/input-url
(string->url uri)
get-pure-port
(lambda (input)
(call-with-output-file
file
(lambda (output)
(copy-port input output))
#:exists 'replace)))
file))))
(define/override (image->mimetype)
(or mime-type
'no-mimetype))
(super-new)))
(define booklet-provider-media-server%
(class booklet-provider%
(define/override (has-booklet?)
#f)
(define/override (booklet-file)
#f)
(super-new)))
(define (audio-resource? resource)
(let ((content-type
(upnp:media-resource-content-type
resource)))
(and content-type
(string-prefix?
content-type
"audio/"))))
(define (resource-seekable? resource)
(let ((protocol-info
(upnp:media-resource-protocol-info
resource)))
(and protocol-info
(regexp-match?
#px"DLNA[.]ORG_OP=(?:01|10|11)"
protocol-info))))
(define track-media-server%
(class track%
(init-field
library
entry)
(check/c track-media-server%
entry
upnp:media-item?)
(define source-resource
(or
(findf
audio-resource?
(upnp:media-item-resources entry))
(car
(upnp:media-item-resources entry))))
(define resource
(new media-resource%
[uri
(upnp:media-resource-uri
source-resource)]
[mime-type
(upnp:media-resource-content-type
source-resource)]
[protocol-info
(upnp:media-resource-protocol-info
source-resource)]
[seekable?
(resource-seekable?
source-resource)]))
(super-new
[resource resource]
[music-library-factory-id
(let ((cfg (send library get-cfg)))
(library-ref
(send cfg get-id)
(send cfg get-kind)
(send cfg get-kind-version)))]
[track-factory-id
'media-server-item]
[track-relive-info
(list
(upnp:media-entry-parent-id entry)
(upnp:media-entry-id entry))]
[tag-data-provider
(new tag-data-provider-media-server%
[entry entry]
[resource source-resource])]
[image-provider
(new image-provider-media-server%
[uri
(upnp:media-item-album-art-uri
entry)])]
[booklet-provider
(new booklet-provider-media-server%)])))
library/track-store.rkt
+175
View File
@@ -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))))
library/track-tag-data.rkt
+7
View File
@@ -0,0 +1,7 @@
#lang racket/base
(provide (struct-out track-tag-data))
(struct track-tag-data
(title artist album number length)
#:prefab)
utils.rkt → misc/utils.rkt
+86 -10
View File
@@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require racket/gui (require racket/gui
racket/contract
xml xml
xml/xexpr xml/xexpr
simple-log simple-log
@@ -12,7 +13,6 @@
simple-row-formatter simple-row-formatter
while while
open-file-manager open-file-manager
basedir
dbg-rktplayer dbg-rktplayer
err-rktplayer err-rktplayer
info-rktplayer info-rktplayer
@@ -24,11 +24,59 @@
path-equal? path-equal?
make-select-list make-select-list
new-id new-id
check/c
check/c*
(all-from-out racket/contract)
) )
(sl-def-log rktplayer) (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 (define-syntax while
(syntax-rules () (syntax-rules ()
((_ cond body ...) ((_ cond body ...)
@@ -114,15 +162,6 @@
[else (do-open "xdg-open" folder)])) [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) (define (path-equal? p1 p2)
(let ((p1* (build-path p1)) (let ((p1* (build-path p1))
(p2* (build-path p2)) (p2* (build-path p2))
@@ -169,4 +208,41 @@
(id (string->symbol (format "id-~a-~a" s r)))) (id (string->symbol (format "id-~a-~a" s r))))
id)) id))
(module+ test
(require rackunit)
(define (multiply a b c)
(check/c* (my-class multiply)
(a number?)
(b number?)
(c symbol?))
(format "symbol ~a = ~a" c (* a b)))
(check-equal? (multiply 2 3 'answer)
"symbol answer = 6")
(check-not-exn
(lambda ()
(define value 1)
(check/c my-class value number?)))
(check-exn
exn:fail:contract?
(lambda ()
(multiply 2 "3" 'answer)))
(check-exn
#rx"my-class:multiply"
(lambda ()
(multiply 2 3 "answer")))
(check-not-exn
(lambda ()
(define value "root")
(check/c value (or/c path? string?))))
(check-exn
#rx"or/c"
(lambda ()
(define value 42)
(check/c my-class value (or/c path? string?)))))
music-library.rkt
-53
View File
@@ -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))
))
)
)
player.rkt → play/base/player.rkt
+55 -37
View File
@@ -2,7 +2,8 @@
(require racket/class (require racket/class
racket-audio racket-audio
"utils.rkt" "../../misc/utils.rkt"
"../../library/base/media-resource.rkt"
lru-cache lru-cache
) )
@@ -114,11 +115,23 @@
(define/public (get-volume) (define/public (get-volume)
(check-player) (check-player)
(audio-volume player)) (* 100.0
(sqrt
(/ (min 100.0
(max 0.0
(audio-volume player)))
100.0))))
(define/public (set-volume! percentage) (define/public (set-volume! percentage)
(check-player) (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*) (define/public (set-list! playlist*)
;; if the player exists and is playing, stop it. ;; if the player exists and is playing, stop it.
@@ -138,14 +151,25 @@
(define/public (play playlist*) (define/public (play playlist*)
(send this playlist! 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) (define/public (play-track nr)
(check-player) (check-player)
(when (and (>= nr 0) (< nr (send playlist length))) (when (and (>= nr 0) (< nr (send playlist length)))
(let ((track (send playlist track nr))) (let ((track (send playlist track nr)))
(let ((id (audio-play! player (send track get-file)))) (when track
(register-music-id&track-nr id nr))))) (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) (define/public (next)
(check-player) (check-player)
@@ -154,21 +178,18 @@
(let ((track-nr (music-id->track-nr music-id))) (let ((track-nr (music-id->track-nr music-id)))
(if (eq? track-nr #f) (if (eq? track-nr #f)
(error "Unexpected: no track-nr for given music-id") (error "Unexpected: no track-nr for given music-id")
(begin (if (eq? repeat 'repeat-one)
(cond (send this play-track track-nr)
((eq? repeat 'repeat-one) (play-track track-nr)) (let ((next-track-nr
((eq? repeat 'repeat-all) (send playlist
(set! track-nr (+ track-nr 1)) next-available-track-index
(when (>= track-nr (send playlist length)) track-nr
(set! track-nr 0)) (eq? repeat 'repeat-all))))
(play-track track-nr)) (if next-track-nr
(else (send this
(set! track-nr (+ track-nr 1)) play-track
(if (>= track-nr (send playlist length)) next-track-nr)
(stop) (send this stop))))
(play-track track-nr)))
)
)
) )
) )
) )
@@ -181,20 +202,17 @@
(let ((track-nr (music-id->track-nr music-id))) (let ((track-nr (music-id->track-nr music-id)))
(if (eq? track-nr #f) (if (eq? track-nr #f)
(error "Unexpected: no track-nr for given music-id") (error "Unexpected: no track-nr for given music-id")
(begin (if (eq? repeat 'repeat-one)
(cond (send this play-track track-nr)
((eq? repeat 'repeat-one) (play-track track-nr)) (let ((previous-track-nr
((eq? repeat 'repeat-all) (send playlist
(set! track-nr (- track-nr 1)) previous-available-track-index
(when (< track-nr 0) track-nr
(set! track-nr (- (send playlist length) 1))) (eq? repeat 'repeat-all))))
(play-track track-nr)) (send this
(else play-track
(set! track-nr (- track-nr 1)) (or previous-track-nr
(when (< track-nr 0) (set! track-nr 0)) track-nr))))
(play-track track-nr))
)
)
) )
) )
) )
@@ -215,8 +233,8 @@
(send this play!))) (send this play!)))
(define/public (stop) (define/public (stop)
(check-player) (unless (eq? player #f)
(audio-stop! player)) (audio-stop! player)))
(define/public (seek percentage) (define/public (seek percentage)
(check-player) (check-player)
play/base/renderer.rkt
+163
View File
@@ -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)))
play/dlna-player.rkt
+588
View File
@@ -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"))))
play/dlna.rkt
+113
View File
@@ -0,0 +1,113 @@
#lang racket
(require racket/class
racket/list
racket-sonos
racket-upnp
"renderer-sonos.rkt"
"renderer-upnp.rkt"
"../misc/utils.rkt")
(provide check-dlna-players)
(define running-sem (make-semaphore 1))
(define running #f)
(define (normalized-device-id device)
(let ((id (upnp-device-udn device)))
(and id
(let ((match
(regexp-match
#px"(?i:RINCON_[0-9A-F]+)"
id)))
(if match
(string-upcase
(car match))
(regexp-replace
#px"(?i:^uuid:)"
id
""))))))
(define (represented-by-sonos-group? device member-ids)
(let ((id (normalized-device-id device)))
(and id
(ormap
(lambda (member-id)
(string-ci=? id member-id))
member-ids))))
(define (make-generic-renderers devices preferences
#:excluded-ids [excluded-ids '()])
(for/list ((device
(in-list
(filter media-renderer? devices)))
#:unless
(represented-by-sonos-group?
device
excluded-ids))
(new renderer-upnp%
[upnp-device device]
[name
(if (sonos-device? device)
(sonos-device-name device)
#f)]
[preferences preferences])))
(define (discover-renderers preferences)
(let* ((devices (query-upnp-devices 'all))
(groups
(with-handlers
((exn:fail?
(lambda (e)
(warn-rktplayer
"Could not read Sonos topology; using generic UPnP renderers: ~a"
(exn-message e))
'())))
(sonos-groups devices)))
(renderers
(if (null? groups)
(make-generic-renderers
devices
preferences)
(append
(make-generic-renderers
devices
preferences
#:excluded-ids
(append-map
sonos-group-member-ids
groups))
(for/list ((group (in-list groups)))
(new renderer-sonos%
[sonos-group group]
[preferences preferences]))))))
(sort renderers
string-ci<?
#:key
(lambda (renderer)
(send renderer get-name)))))
(define (check-dlna-players gui preferences)
(let ((can-check
(begin
(semaphore-wait running-sem)
(let ((was-running running))
(unless was-running
(set! running #t))
(semaphore-post running-sem)
(not was-running)))))
(if can-check
(void
(thread
(lambda ()
(dynamic-wind
void
(lambda ()
(send gui
set-dlna-renderers!
(discover-renderers preferences)))
(lambda ()
(semaphore-wait running-sem)
(set! running #f)
(semaphore-post running-sem))))))
(send gui dlna-query-busy))))
play/playlist-cache.rkt
+280
View File
@@ -0,0 +1,280 @@
#lang racket/base
(require net/url
racket/async-channel
racket/class
racket/file
racket/path
racket/string
"../library/base/media-resource.rkt"
"../misc/utils.rkt")
(provide playlist-cache%
playlist-cache-root
clear-playlist-cache!)
(define (playlist-cache-root)
(build-path (find-system-path 'cache-dir)
"rktplayer"))
(define (safe-name value)
(regexp-replace* #px"[<>:\"/\\\\|?*]"
(format "~a" value)
"_"))
(define (resource-extension resource)
(let* ((uri (send resource get-uri))
(without-query
(regexp-replace #px"[?#].*$" uri ""))
(uri-extension
(regexp-match #px"(?i:[.]([a-z0-9]{1,8})$)"
without-query))
(mime-type (send resource get-mime-type)))
(cond
(uri-extension
(string-append "."
(string-downcase
(cadr uri-extension))))
((member mime-type
'("audio/flac"
"audio/x-flac"
"application/flac")) ".flac")
((or (equal? mime-type "audio/mpeg")
(equal? mime-type "audio/mp3")) ".mp3")
((or (equal? mime-type "audio/opus")
(equal? mime-type "audio/ogg")) ".opus")
((member mime-type
'("audio/wav"
"audio/wave"
"audio/x-wav")) ".wav")
((member mime-type
'("audio/mp4"
"audio/x-m4a")) ".m4a")
((equal? mime-type "audio/aac") ".aac")
((equal? mime-type "audio/x-ms-wma") ".wma")
(else ".audio"))))
(define (content-length headers)
(for/or ((header (in-list headers)))
(let ((matched
(regexp-match
#px#"(?i:^content-length:[ \t]*([0-9]+)[ \t]*$)"
header)))
(and matched
(string->number
(bytes->string/utf-8
(cadr matched)))))))
(define (successful-status? status)
(regexp-match? #px#"^HTTP/[0-9.]+ 2[0-9][0-9]" status))
(define (clear-playlist-cache! [playlist-id #f])
(let ((target
(if playlist-id
(build-path (playlist-cache-root)
(safe-name playlist-id))
(playlist-cache-root))))
(when (directory-exists? target)
(with-handlers ([exn:fail? (lambda (e) (void))])
(delete-directory/files target)))))
(define playlist-cache%
(class object%
(init-field
playlist-id
[updated (lambda (entry downloaded total) (void))])
(define directory
(build-path (playlist-cache-root)
(safe-name playlist-id)))
(define queue
(make-async-channel))
(define generations
(make-hash))
(define stopped?
#f)
(define worker-custodian
(make-custodian))
(define/private (entry-generation entry)
(hash-ref generations
(send entry get-id)
0))
(define/private (next-generation! entry)
(hash-update! generations
(send entry get-id)
add1
0)
(entry-generation entry))
(define/private (cache-file entry)
(let ((resource
(send (send entry get-track)
get-resource)))
(build-path directory
(string-append
(safe-name (send entry get-id))
(resource-extension resource)))))
(define/private (notify! entry downloaded total)
(with-handlers
((exn:fail?
(lambda (exception)
(warn-rktplayer
"Cache status callback failed: ~a"
(exn-message exception)))))
(updated entry downloaded total)))
(define/private (copy-download!
input temporary entry total)
(let ((downloaded 0)
(last-reported 0)
(buffer (make-bytes 65536)))
(dynamic-wind
void
(lambda ()
(call-with-output-file
temporary
(lambda (output)
(let loop ()
(let ((count
(read-bytes-avail!* buffer input)))
(unless (eof-object? count)
(write-bytes buffer output 0 count)
(set! downloaded (+ downloaded count))
(when (>= (- downloaded last-reported)
1048576)
(set! last-reported downloaded)
(notify! entry downloaded total))
(loop)))))
#:exists 'replace
#:mode 'binary))
(lambda ()
(close-input-port input)))
downloaded))
(define/private (finish-download!
entry generation target temporary
downloaded total)
(if (and (not stopped?)
(= generation
(entry-generation entry)))
(begin
(when (file-exists? target)
(delete-file target))
(rename-file-or-directory temporary target)
(send entry set-cache-file! target)
(notify! entry downloaded total))
(when (file-exists? temporary)
(delete-file temporary))))
(define/private (download! entry generation)
(let* ((resource
(send (send entry get-track)
get-resource))
(uri (send resource get-uri))
(target (cache-file entry))
(temporary
(string->path
(string-append (path->string target)
".part"))))
(let ((finished? #f))
(dynamic-wind
void
(lambda ()
(make-directory* directory)
(let-values
(((status headers input)
(http-sendrecv/url
(string->url uri)
#:headers
(list "Connection: close"))))
(unless (successful-status? status)
(close-input-port input)
(error 'playlist-cache%
"download failed for ~a: ~a"
uri
status))
(let* ((total (content-length headers))
(downloaded
(copy-download!
input temporary entry total)))
(finish-download!
entry generation target temporary
downloaded total)
(set! finished? #t))))
(lambda ()
(when (and (not finished?)
(file-exists? temporary))
(delete-file temporary)))))))
(define worker
(parameterize
((current-custodian worker-custodian))
(thread
(lambda ()
(let loop ()
(let ((request (async-channel-get queue)))
(unless (eq? request 'stop)
(let ((entry (car request))
(generation (cadr request)))
(with-handlers
((exn:fail?
(lambda (exception)
(when (= generation
(entry-generation entry))
(send entry
set-cache-failed!
(exn-message exception))
(notify! entry 0 #f)))))
(download! entry generation))
(loop)))))))))
(define/public (ensure-entry! entry)
(let ((track (send entry get-track)))
(when track
(let* ((resource (send track get-resource))
(file (send resource get-file)))
(cond
(file
(send entry set-cache-file! file))
((regexp-match? #px"(?i:^https?://)"
(send resource get-uri))
(let ((target (cache-file entry)))
(if (file-exists? target)
(send entry set-cache-file! target)
(let ((generation
(next-generation! entry)))
(send entry set-cache-downloading!)
(notify! entry 0 #f)
(async-channel-put
queue
(list entry generation)))))))))))
(define/public (drop-entry! entry)
(next-generation! entry)
(let ((file (send entry get-cache-file)))
(when (and file
(path? file)
(file-exists? file)
(equal? (simplify-path directory)
(simplify-path
(path-only file))))
(delete-file file))))
(define/public (clear!)
(when (directory-exists? directory)
(delete-directory/files directory)))
(define/public (stop!)
(unless stopped?
(set! stopped? #t)
(custodian-shutdown-all
worker-custodian)))
(super-new)))
play/playlist-entry.rkt
+194
View File
@@ -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))))
play/playlist-gui.rkt
+218
View File
@@ -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"))
play/playlist.rkt
+487
View File
@@ -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))
play/renderer-sonos.rkt
+29
View File
@@ -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])))
play/renderer-upnp.rkt
+35
View File
@@ -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])))
playlist.rkt
-438
View File
@@ -1,438 +0,0 @@
#lang racket
(require racket/class
"music-library.rkt"
racket-audio
"utils.rkt"
racket-sprintf
keystore/class
racket/list
)
(provide track%
playlist%
)
(define the-displayln displayln)
(define list-for-each for-each)
(define list-length length)
(define next-track-id 0)
(define track%
(class object%
(init-field
[file #f]
[title ""]
[artist ""]
[album ""]
[length 0]
[number 0]
)
(define/public (displayln)
(the-displayln (format "~a - ~a - ~a - ~a"
number
title
album
length)))
(define my-id (begin
(set! next-track-id (+ next-track-id 1))
(when (> next-track-id 10000000)
(set! next-track-id 1))
next-track-id))
(define/public (get-file) file)
(define/public (get-title) title)
(define/public (get-artist) artist)
(define/public (get-album) album)
(define/public (get-number) number)
(define/public (get-length) length)
(define/public (get-id) my-id)
(define/public (booklet-file)
(let* ((dir (path-only file))
(booklet-file (build-path dir "booklet.pdf")))
booklet-file))
(define/public (has-booklet?)
(file-exists? (send this booklet-file)))
(define/public (track< t2)
(if (string-ci<? album (send t2 get-album))
#t
(if (string-ci=? album (send t2 get-album))
(< number (send t2 get-number))
#f))
)
(define (read-tags)
(let* ((f (if (path? file) (path->string file) file))
(tags (id3-tags f))
(tmpfile #f))
(unless (tags-valid? tags)
(let ((nfile (make-temporary-file "rktplayer-~a" #:copy-from f)))
(set! tags (id3-tags nfile))
(set! tmpfile nfile)
))
(unless (eq? tmpfile #f)
(delete-file tmpfile))
tags
)
)
(define/public (image->file* to-file)
#f)
(define/public (image->file to-file*)
(let ((to-file (format "~a" to-file*))
(tags (read-tags)))
(dbg-rktplayer "image->file ~a" to-file)
(let ((image-from-tags (λ ()
(if (tags-valid? tags)
(let ((ext (tags-picture->ext tags)))
(if (eq? ext #f)
#f
(let ((path (string-append to-file "." (symbol->string ext))))
(if (tags-picture->file tags path)
path
#f)
)
)
)
#f)
)
)
)
(let ((path (image-from-tags)))
(dbg-rktplayer "image-from-tags: ~a" path)
(if (eq? path #f)
(let* ((bd (basedir file))
(files (filter
(λ (f)
(let ((file (build-path bd f)))
(file-exists? file)))
(list "cover.jpg" "cover.png" "folder.jpg" "folder.png"))))
(if (null? files)
#f
(let ((file (string-append to-file (bytes->string/utf-8 (path-get-extension (car files))))))
(copy-file (build-path bd (car files)) file #:exists-ok? #t)
(dbg-rktplayer "image from basedir: ~a" file)
(format "~a" file))
))
path))
)
)
)
(define/public (image->mimetype*)
#f)
(define/public (image->mimetype)
(let ((tags (read-tags)))
(if (tags-valid? tags)
(tags-picture->mimetype tags)
'no-mimetype)))
(super-new)
(begin
(let ((use-tags #t))
(if use-tags
(unless (eq? file #f)
(let ((tags (read-tags)))
(if (tags-valid? tags)
(begin
(set! title (tags-title tags))
(set! artist (tags-artist tags))
(set! album (tags-album tags))
(set! number (tags-track tags))
(set! length (tags-length tags))
)
(begin
(set! title "invalid tags")
(set! artist "invalid tags")
(set! album "invalid tags")
(set! number number)
(set! length -1)
)
)
)
)
(unless (eq? file #f)
(set! title (format "~a" file))
(set! number 0))
)
)
)
)
)
(define list-len length)
(define orig-for-each for-each)
(define playlist%
(class object%
(init-field
[start-map #f]
[max-tracks 100]
[name "Default"]
[id #f]
[settings #f]
)
(define store (new keystore% [file 'rktplayer]))
(define tracks '())
(define (can-add? file)
(and (<= (list-len tracks) max-tracks)
(is-music-file? file)))
(define (add-track* file)
(let ((track (new track% [file file])))
(set! tracks (append tracks (list track)))))
(define (read-tracks-internal dir)
;(displayln (format "dir = ~a" dir))
(if (> (list-len tracks) max-tracks)
'done
(if (file-exists? dir)
(when (can-add? dir)
(add-track dir))
(if (directory-exists? dir)
(let ((content (directory-list dir)))
(orig-for-each (λ (entry)
(let ((p (build-path dir entry)))
(if (directory-exists? p)
(read-tracks-internal p)
(when (and (file-exists? p) (can-add? p))
;(displayln (format "Adding ~a" p))
(add-track* p)))))
content))
'no-file-or-dir
)
)
)
)
;(define/public (set-name! n)
; (set! name n))
;(define/public (set-id! id*)
; (set! id id*))
;(define/public (get-id)
; id)
;(define/public (get-name)
; name)
(define/public (tabs)
(map (λ (k)
(if (string? k)
(string->symbol k)
k))
(send store get 'tabs '(tabkey-default)))
)
(define/public (tab-count)
(list-length (tabs)))
(define/public (make-tab-key)
(string->symbol
(format "tabkey-~a-~a" (current-milliseconds) (random 10000))))
(define/public (get-tab-name idx)
(let* ((t (tabs))
(entry (list-ref t idx)))
(let ((v (send store get entry (list (format "Playlist-~a" idx) '()))))
(car v))))
(define/public (set-tab-name! idx name)
(let* ((t (tabs))
(entry (list-ref t idx))
(v (send store get entry (list (format "Playlist-~a" idx) '())))
)
(send store set! entry (list name (cadr v)))
)
)
(define/public (tab-id idx)
(let ((t (tabs)))
(list-ref t idx)))
(define/public (tab-index id)
(let ((t (tabs)))
(letrec ((f (λ (t idx)
(if (null? t)
#f
(if (eq? (car t) id)
idx
(f (cdr t) (+ idx 1)))))))
(f t 0))))
(define/public (drop-tab! idx)
(let* ((t (tabs))
(entry (list-ref t idx))
)
(send store set! 'tabs (list-drop! t idx))
(send store drop! entry)
))
(define/public (add-tab!)
(let* ((t (tabs))
(new-entry (send this make-tab-key)))
(send store set! 'tabs (append t (list new-entry)))
)
)
(define/public (save-tab!)
(let* ((entry id)
(idx (send this tab-index entry))
)
(dbg-rktplayer "entry id = ~a, ~a" entry idx)
(if (eq? idx #f)
(err-rktplayer "Cannot get tab for id ~a" entry)
(let ((value (list (send this get-tab-name idx)
(map (λ (track)
(send track get-file))
tracks))))
(send store set! entry value)
)
)
)
)
(define/public (load-tab idx)
(let* ((t (tabs))
(entry (list-ref t idx))
)
(dbg-rktplayer "loading ~a" entry)
(set! id entry)
(set! tracks '())
(let ((value (send store get entry (list "Default" '()))))
(set! name (car value))
(list-for-each (λ (file)
(when (file-exists? file)
(send this add-track file #f)))
(cadr value))
)
)
#t
)
(define/public (read-tracks)
(set! tracks '())
(read-tracks-internal start-map)
(set! tracks
(sort tracks (λ (t1 t2)
(send t1 track< t2))))
(send this save-tab!)
)
(define/public (length)
(list-len tracks))
(define/public (add-track file . args)
(add-track* file)
(when (null? args)
(send this save-tab!))
)
(define/public (move-track from-idx to-idx)
(let ((tr (list-ref tracks from-idx))
(idx 0))
(if (= from-idx to-idx)
#t
(begin
(when (< from-idx to-idx)
(set! to-idx (- to-idx 1)))
(let* ((l1 (if (= from-idx 0)
'()
(take tracks from-idx)))
(l2 (drop tracks (+ from-idx 1)))
(l (append l1 l2))
)
(set! tracks (append
(if (= to-idx 0) '() (take l to-idx))
(list tr)
(drop l to-idx)))
)
(send this save-tab!)
)
)
)
)
(define/public (drop-id track-id)
(let ((idx (send this index track-id)))
(let* ((l1 (if (= idx 0) '() (take tracks idx)))
(l2 (drop tracks (+ idx 1)))
(l (append l1 l2)))
(set! tracks l)
(send this save-tab!)
)
)
)
(define/public (track i)
(list-ref tracks i))
(define/public (display-tracks)
(orig-for-each (λ (track)
(send track displayln))
tracks))
(define/public (for-each f)
(let ((idx 0))
(orig-for-each (λ (track)
(f idx track)
(set! idx (+ idx 1)))
tracks)
)
)
(define/public (track-id i)
(string->symbol (format "track-~a" (+ i 1))))
(define/public (index id)
(- (string->number (substring (symbol->string id) 6)) 1))
(define/public (to-html)
(define (formatter row)
(let* ((track-idx (car row))
(track (track track-idx)))
(list
(list 'td (list (list 'class "number"))
(format "~a." (send track get-number)))
(list 'td (list (list 'class "title"))
(send track get-title))
(list 'td (list (list 'class "album"))
(send track get-album))
(list 'td (list (list 'class "length"))
(let* ((length-s (send track get-length))
(hour (quotient length-s 3600))
(min (quotient (remainder length-s 3600) 60))
(sec (remainder (remainder length-s 3600) 60)))
(sprintf "%02d:%02d:%02d" hour min sec)))
)))
(letrec ((f (λ (i N)
(if (< i N)
(cons (list (send this track-id i) i) (f (+ i 1) N))
'()))))
(dbg-rktplayer "Number of rows in playlist: ~a" (send this length))
(let ((rows (f 0 (send this length))))
(mktable rows 'tracks formatter))))
(super-new)
(begin
(if (eq? start-map #f)
(send this load-tab 0)
(set! id (send this tab-id id)))
)
)
)
rktplayer.rkt
+21 -7
View File
@@ -1,20 +1,24 @@
#lang racket #lang racket
(require racket/gui (require racket/gui
"gui.rkt" "gui/gui.rkt"
"tray.rkt" "gui/tray.rkt"
"translate.rkt" "gui/translate.rkt"
"library/libraries-config.rkt"
"library/library-factory.rkt"
"library/library-filesystem.rkt"
"library/library-media-server.rkt"
simple-ini/class simple-ini/class
racket-audio racket-audio
racket-webview racket-webview
racket/runtime-path racket/runtime-path
"utils.rkt" "misc/utils.rkt"
net/uri-codec net/uri-codec
) )
(provide run) (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")) (define log-file (build-path (find-system-path 'cache-dir) ".rktplayer.log"))
@@ -63,10 +67,21 @@
[ini ini] [ini ini]
[file-getter my-file-getter] [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))) (displayln (format "ini file: ~a" (send ini get-file)))
(set-lang! (send ini get 'settings 'language 'en)) (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])) (tray (new rktplayer-tray% [rktplayer-gui window]))
) )
(set! rktplayer-window window) (set! rktplayer-window window)
@@ -117,4 +132,3 @@
) )
;(run) ;(run)
settings.rkt
-274
View File
@@ -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)
)
)