Files
rktplayer/gui/settings.rkt
T

801 lines
30 KiB
Racket

#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)
)
)