OK
diff --git a/gui/styles.css b/gui/html/styles.css
similarity index 94%
rename from gui/styles.css
rename to gui/html/styles.css
index 9a74e82..d50335f 100644
--- a/gui/styles.css
+++ b/gui/html/styles.css
@@ -273,12 +273,14 @@ table.tracks td.title, table.tracks td.album {
}
table.tracks tr, table.tracks td,
-table.libraries tr, table.libraries td {
+table.libraries tr, table.libraries td,
+table.renderers tr, table.renderers td {
cursor: default;
user-select: none;
}
-table.tracks tr:hover, table.libraries tbody tr:hover {
+table.tracks tr:hover, table.libraries tbody tr:hover,
+table.renderers tbody tr:hover {
background: #e0e0e0;
color: black;
transition: all 0.5s ease-in;
@@ -296,6 +298,18 @@ table.libraries tbody tr.current {
color: #f3961e;
}
+table.tracks tr.unavailable {
+ color: #777777;
+}
+
+table.tracks tr.unavailable:hover {
+ color: #777777;
+}
+
+table.tracks tr.failed {
+ color: #a06060;
+}
+
.album-art .content img {
width: auto;
height: calc(100% - 20px);
@@ -388,6 +402,11 @@ input.v-slider {
animation: blink 3s infinite both;
}
+.error {
+ color: #d60000;
+ font-weight: bold;
+}
+
@keyframes blink {
0%,
50%,
diff --git a/gui/library-dialog.html b/gui/library-dialog.html
deleted file mode 100644
index f3894cc..0000000
--- a/gui/library-dialog.html
+++ /dev/null
@@ -1,41 +0,0 @@
-
-
-
-
-
-
RktPlayer - A music player - library entry
-
-
-
-
- Action:
- Action
-
-
-
- Name:
-
-
-
Local path:
-
- Browse
-
-
-
- Host:
-
-
- Prefixes:
-
-
-
-
- OK
- Cancel
- devtools
-
-
-
\ No newline at end of file
diff --git a/gui/settings.rkt b/gui/settings.rkt
new file mode 100644
index 0000000..ac28279
--- /dev/null
+++ b/gui/settings.rkt
@@ -0,0 +1,800 @@
+#lang racket
+
+(require racket-webview
+ racket/runtime-path
+ racket/gui
+ racket-sprintf
+ open-app
+ xml
+ (prefix-in upnp: racket-upnp)
+ "../misc/utils.rkt"
+ "translate.rkt"
+ "../play/playlist.rkt"
+ "../play/base/player.rkt"
+ "../library/libraries-config.rkt"
+ "../library/library-factory.rkt"
+ "../play/base/renderer.rkt"
+ )
+
+(provide
+ (all-from-out racket-webview)
+ settings%
+ )
+
+(define-runtime-path rkt-gui-dir "html")
+
+(define library-dlg%
+ (class wv-dialog%
+ (init-field [kind 'filesystem] [result-cb (λ args #f)]
+ [id (new-id)] [name ""] [local-path ""]
+ [host ""] [item-limit 100]
+ [kind-editable? #t])
+ (inherit-field settings icon parent)
+
+ (super-new
+ [html-path "library-dialog.html"]
+ [title (tr 'settings-library)]
+ [icon (build-path rkt-gui-dir "rktplayer.png")]
+ [quit-on-close #f]
+ )
+
+ (define initialized #f)
+ (define btn-ok #f)
+ (define btn-cancel #f)
+ (define lbl-name #f)
+ (define lbl-kind #f)
+ (define lbl-local-path #f)
+ (define btn-browse #f)
+ (define lbl-media-server #f)
+ (define lbl-media-server-root #f)
+ (define lbl-media-server-item-limit #f)
+ (define btn-refresh-media-servers #f)
+ (define btn-media-server-root-up #f)
+ (define div-filesystem-fields #f)
+ (define div-media-server-fields #f)
+ (define txt-media-server-root #f)
+ (define sel-library-kind #f)
+ (define sel-media-server #f)
+ (define sel-media-server-container #f)
+ (define inp-local-path #f)
+ (define inp-name #f)
+ (define inp-media-server-item-limit #f)
+ (define media-servers '())
+ (define media-server-containers '())
+ (define media-server-root-id
+ (if (and (eq? kind 'media-server)
+ (not (string=? local-path "")))
+ local-path
+ "0"))
+ (define media-server-root-path '())
+ (define media-server-root-parents '())
+ (define media-server-root-request 0)
+
+ (define/public (set-labels)
+ (send btn-ok set-innerHTML! (tr 'ok))
+ (send btn-cancel set-innerHTML! (tr 'cancel))
+ (send lbl-name set-innerHTML! (tr 'name))
+ (send lbl-kind set-innerHTML! (tr 'library-kind))
+ (send lbl-local-path set-innerHTML! (tr 'local-path))
+ (send lbl-media-server set-innerHTML! (tr 'media-servers))
+ (send lbl-media-server-root
+ set-innerHTML!
+ (tr 'media-server-root))
+ (send lbl-media-server-item-limit
+ set-innerHTML!
+ (tr 'media-server-item-limit))
+ (send btn-browse set-innerHTML! (tr 'browse))
+ (send btn-refresh-media-servers set-innerHTML! (tr 'refresh))
+ (send btn-media-server-root-up set-innerHTML! (tr 'up))
+ )
+
+ (define/private (media-server-label server)
+ (format "~a (~a)"
+ (upnp:media-server-name server)
+ (upnp:media-server-address server)))
+
+ (define/private (update-media-servers!)
+ (let* ((items
+ (if (null? media-servers)
+ (list
+ (list -1
+ (tr 'no-media-servers)))
+ (for/list ((server
+ (in-list media-servers))
+ (idx (in-naturals)))
+ (list idx
+ (media-server-label server)))))
+ (selected-idx
+ (or
+ (for/first ((server (in-list media-servers))
+ (idx (in-naturals))
+ #:when
+ (member host
+ (filter
+ values
+ (list
+ (upnp:upnp-device-udn server)
+ (upnp:media-server-name server)
+ (upnp:media-server-address server)))))
+ idx)
+ (if (null? media-servers)
+ -1
+ 0))))
+ (send sel-media-server
+ set-options!
+ items
+ selected-idx)))
+
+ (define/public (refresh-media-servers)
+ (set! media-servers '())
+ (update-media-servers!)
+ (send btn-refresh-media-servers
+ set-innerHTML!
+ (tr 'searching))
+ (void
+ (thread
+ (lambda ()
+ (with-handlers
+ ((exn:fail?
+ (lambda (exception)
+ (warn-rktplayer
+ "Could not query UPnP media servers: ~a"
+ (exn-message exception))
+ (set! media-servers '())
+ (update-media-servers!)
+ (set! media-server-containers '())
+ (update-media-server-root!)
+ (send btn-refresh-media-servers
+ set-innerHTML!
+ (tr 'refresh)))))
+ (set! media-servers
+ (upnp:query-media-servers))
+ (update-media-servers!)
+ (load-media-server-root!)
+ (send btn-refresh-media-servers
+ set-innerHTML!
+ (tr 'refresh)))))))
+
+ (define/private (selected-media-server)
+ (let* ((idx
+ (string->number
+ (get sel-media-server))))
+ (and idx
+ (>= idx 0)
+ (< idx (length media-servers))
+ (list-ref media-servers idx))))
+
+ (define/private (current-library-kind)
+ (string->symbol
+ (get sel-library-kind)))
+
+ (define/private (update-library-kind!)
+ (case (current-library-kind)
+ ((filesystem)
+ (send div-filesystem-fields display 'block)
+ (send div-media-server-fields display 'none))
+ ((media-server)
+ (send div-filesystem-fields display 'none)
+ (send div-media-server-fields display 'block))))
+
+ (define/private (media-server-root-label)
+ (if (null? media-server-root-path)
+ (if (string=? media-server-root-id "0")
+ "/"
+ (format "~a" media-server-root-id))
+ (string-append
+ "/"
+ (string-join
+ media-server-root-path
+ " / "))))
+
+ (define/private (update-media-server-root!
+ [status #f])
+ (let ((items
+ (cond
+ (status
+ (list
+ (list -1 status)))
+ ((null? media-server-containers)
+ (list
+ (list -1
+ (tr 'no-media-server-containers))))
+ (else
+ (cons
+ (list -1
+ (tr 'select-media-server-container))
+ (for/list
+ ((container
+ (in-list media-server-containers))
+ (idx (in-naturals)))
+ (list
+ idx
+ (upnp:media-entry-title
+ container))))))))
+ (send txt-media-server-root
+ set-innerHTML!
+ (media-server-root-label))
+ (send sel-media-server-container
+ set-options!
+ items
+ -1)))
+
+ (define/private (load-media-server-root!)
+ (set! media-server-root-request
+ (add1 media-server-root-request))
+ (let ((request media-server-root-request)
+ (server (selected-media-server))
+ (container-id media-server-root-id))
+ (set! media-server-containers '())
+ (update-media-server-root!
+ (tr 'searching))
+ (if server
+ (void
+ (thread
+ (lambda ()
+ (with-handlers
+ ((exn:fail?
+ (lambda (exception)
+ (warn-rktplayer
+ "Could not browse UPnP media-server container ~a: ~a"
+ container-id
+ (exn-message exception))
+ (when (= request
+ media-server-root-request)
+ (set! media-server-containers '())
+ (update-media-server-root!)))))
+ (let ((containers
+ (filter
+ (lambda (entry)
+ (and
+ (upnp:media-container? entry)
+ (string?
+ (upnp:media-entry-id entry))))
+ (upnp:media-server-browse
+ server
+ container-id
+ #:count
+ (current-media-server-item-limit)))))
+ (when (= request
+ media-server-root-request)
+ (set! media-server-containers
+ containers)
+ (update-media-server-root!)))))))
+ (update-media-server-root!))))
+
+ (define/private (reset-media-server-root!)
+ (set! media-server-root-id "0")
+ (set! media-server-root-path '())
+ (set! media-server-root-parents '())
+ (load-media-server-root!))
+
+ (define/private (open-media-server-container!)
+ (let ((idx
+ (string->number
+ (get sel-media-server-container))))
+ (when (and idx
+ (>= idx 0)
+ (< idx
+ (length media-server-containers)))
+ (let ((container
+ (list-ref media-server-containers
+ idx)))
+ (set! media-server-root-parents
+ (cons
+ (list media-server-root-id
+ media-server-root-path)
+ media-server-root-parents))
+ (set! media-server-root-id
+ (upnp:media-entry-id
+ container))
+ (set! media-server-root-path
+ (append
+ media-server-root-path
+ (list
+ (upnp:media-entry-title
+ container))))
+ (load-media-server-root!)))))
+
+ (define/private (media-server-root-up!)
+ (cond
+ ((not
+ (null? media-server-root-parents))
+ (let ((parent
+ (car media-server-root-parents)))
+ (set! media-server-root-id
+ (car parent))
+ (set! media-server-root-path
+ (cadr parent))
+ (set! media-server-root-parents
+ (cdr media-server-root-parents))
+ (load-media-server-root!)))
+ ((not
+ (string=? media-server-root-id "0"))
+ (reset-media-server-root!))))
+
+ (define (get el)
+ (let ((str (send el get)))
+ (string-trim str)))
+
+ (define/private (current-media-server-item-limit)
+ (let ((value
+ (send inp-media-server-item-limit get)))
+ (if (exact-positive-integer? value)
+ value
+ 100)))
+
+ (define/public (select-library)
+ (let* ((music-library (get inp-local-path))
+ (dir (send this choose-dir
+ (tr 'choose-lib-folder)
+ music-library
+ )))
+ (displayln "Directory kiezen")
+ (if (eq? dir 'showing)
+ 'done
+ (unless (eq? dir #f)
+ (send inp-local-path set! dir))
+ )
+ )
+ )
+
+ (define/override (page-loaded oke)
+ (unless initialized
+ (when oke
+ (set! initialized #t)
+ (set! btn-ok (send this element 'ok))
+ (set! btn-cancel (send this element 'cancel))
+ (set! lbl-name (send this element 'lbl-name))
+ (set! lbl-kind (send this element 'lbl-kind))
+ (set! lbl-local-path (send this element 'lbl-local-path))
+ (set! lbl-media-server (send this element 'lbl-media-server))
+ (set! lbl-media-server-root
+ (send this element
+ 'lbl-media-server-root))
+ (set! lbl-media-server-item-limit
+ (send this element
+ 'lbl-media-server-item-limit))
+ (set! div-filesystem-fields
+ (send this element
+ 'filesystem-fields))
+ (set! div-media-server-fields
+ (send this element
+ 'media-server-fields))
+ (set! txt-media-server-root
+ (send this element
+ 'media-server-root))
+ (set! sel-library-kind
+ (send this element
+ 'selected-library-kind))
+ (set! sel-media-server
+ (send this element
+ 'selected-media-server))
+ (set! sel-media-server-container
+ (send this element
+ 'selected-media-server-container))
+ (set! inp-name (send this element 'name))
+ (set! inp-local-path (send this element 'local-path))
+ (set! inp-media-server-item-limit
+ (send this element
+ 'media-server-item-limit))
+ (set! btn-browse (send this element 'browse))
+ (set! btn-refresh-media-servers
+ (send this element
+ 'refresh-media-servers))
+ (set! btn-media-server-root-up
+ (send this element
+ 'media-server-root-up))
+
+ (send inp-name set! name)
+ (send inp-local-path set! local-path)
+ (send inp-media-server-item-limit
+ set!
+ (format "~a" item-limit))
+ (send sel-library-kind
+ set-options!
+ (list
+ (list 'filesystem
+ (tr 'filesystem))
+ (list 'media-server
+ (tr 'media-server)))
+ kind)
+ (unless kind-editable?
+ (send sel-library-kind
+ set-attr!
+ '((disabled "disabled"))))
+
+ (send this set-labels)
+ (update-library-kind!)
+ (update-media-server-root!)
+
+ (send sel-library-kind
+ on-change!
+ (lambda (value)
+ (update-library-kind!)))
+ (send sel-media-server
+ on-change!
+ (lambda (value)
+ (reset-media-server-root!)))
+ (send sel-media-server-container
+ on-change!
+ (lambda (value)
+ (open-media-server-container!)))
+ (send this refresh-media-servers)
+
+ (send this bind! 'browse 'click (λ (el evt data)
+ (send this select-library)))
+ (send this bind!
+ 'refresh-media-servers
+ 'click
+ (lambda (element event data)
+ (send this refresh-media-servers)))
+ (send this bind!
+ 'media-server-root-up
+ 'click
+ (lambda (element event data)
+ (media-server-root-up!)))
+
+ (send this bind! 'ok 'click (λ (el evt data)
+ (let ((name (get inp-name))
+ (library-kind
+ (string->symbol
+ (get sel-library-kind)))
+ (local-path (get inp-local-path)))
+ (case library-kind
+ ((filesystem)
+ (result-cb
+ id
+ name
+ library-kind
+ local-path
+ host
+ (current-media-server-item-limit))
+ (send this close))
+ ((media-server)
+ (let ((server
+ (selected-media-server)))
+ (when server
+ (result-cb
+ id
+ (if (string=? name "")
+ (upnp:media-server-name
+ server)
+ name)
+ library-kind
+ media-server-root-id
+ (or
+ (upnp:upnp-device-udn
+ server)
+ (upnp:media-server-name
+ server))
+ (current-media-server-item-limit))
+ (send this close))))))))
+ (send this bind! 'cancel 'click (λ (el evt data) (send this close)))
+ (send this bind! 'dev 'click (λ args (send this devtools)))
+ )
+ ))
+ )
+ )
+
+(define settings%
+ (class wv-dialog%
+ (init-field
+ [log-file #f]
+ [renderers '()]
+ [libraries-changed-callback (lambda () (void))]
+ [cache-cleared-callback (lambda () (void))])
+ (inherit-field settings icon parent)
+
+ (super-new
+ [html-path "settings.html"]
+ [title (tr 'settings-title)]
+ [icon (build-path rkt-gui-dir "rktplayer.png")]
+ [quit-on-close #f]
+ )
+
+ (define initialized #f)
+ (define btn-ok #f)
+ (define btn-cancel #f)
+ (define btn-add #f)
+ (define btn-edit #f)
+ (define btn-remove #f)
+ (define btn-clear-cache #f)
+ (define lbl-language #f)
+ (define lbl-name #f)
+ (define lbl-kind #f)
+ (define lbl-local-path #f)
+ (define lbl-host #f)
+ (define lbl-lib #f)
+ (define lbl-renderers #f)
+ (define lbl-renderer-name #f)
+ (define lbl-volume-curve #f)
+ (define renderer-body #f)
+ (define div-language #f)
+ (define sel-language #f)
+
+ (define libs
+ (send (get-library-factory)
+ get-libraries-config))
+
+ (define cfg (send settings clone 'settings))
+
+ (define/public (set-labels)
+ (send btn-ok set-innerHTML! (tr 'ok))
+ (send btn-cancel set-innerHTML! (tr 'cancel))
+ (send btn-add set-innerHTML! (tr 'library-add))
+ (send btn-edit set-innerHTML! (tr 'library-edit))
+ (send btn-remove set-innerHTML! (tr 'library-remove))
+ (send btn-clear-cache
+ set-innerHTML!
+ (tr 'clear-cache))
+ (send lbl-language set-innerHTML! (tr 'language))
+ (send lbl-name set-innerHTML! (tr 'name))
+ (send lbl-kind set-innerHTML! (tr 'library-kind))
+ (send lbl-local-path set-innerHTML! (tr 'local-path))
+ (send lbl-host set-innerHTML! (tr 'host))
+ (send lbl-lib set-innerHTML! (tr 'lbl-libary-path))
+ (send lbl-renderers set-innerHTML! (tr 'renderers))
+ (send lbl-renderer-name set-innerHTML! (tr 'name))
+ (send lbl-volume-curve
+ set-innerHTML!
+ (tr 'logarithmic-volume))
+ )
+
+ (define/public (update-renderers)
+ (let ((rows
+ (for/list ((renderer (in-list renderers))
+ (idx (in-naturals)))
+ (list
+ 'tr
+ (list (list 'id
+ (format "renderer-~a" idx)))
+ (list 'td
+ '((class "name"))
+ (send renderer get-name))
+ (list
+ 'td
+ '((class "volume-curve"))
+ (list
+ 'input
+ (append
+ (list
+ '(type "checkbox")
+ '(class "renderer-volume-curve")
+ (list 'id
+ (format "renderer-volume-curve-~a"
+ idx)))
+ (if (eq? (send renderer
+ get-volume-curve)
+ 'logarithmic)
+ '((checked "checked"))
+ '()))))))))
+ (send renderer-body
+ set-innerHTML!
+ (apply string-append
+ (map xexpr->string rows)))
+ (send this
+ bind!
+ "table.renderers input.renderer-volume-curve"
+ 'change
+ (lambda (el evt data)
+ (let ((idx
+ (string->number
+ (substring
+ (format "~a" (send el id))
+ (string-length
+ "renderer-volume-curve-")))))
+ (send (list-ref renderers idx)
+ set-volume-curve!
+ (if (send el get)
+ 'logarithmic
+ 'linear)))))))
+
+ (define/public (update-libraries)
+ (let ((count (send libs count)))
+ (letrec ((f (λ (i)
+ (if (= i count)
+ '()
+ (cons
+ (let* ((id (send libs library-id i))
+ (entry (begin
+ (dbg-rktplayer "index = ~a, id = ~a, symbol? id = ~a" i id (symbol? id))
+ (send libs get-library id)))
+ (name (send entry get-name))
+ (kind (send entry get-kind))
+ (local-path (send entry get-root))
+ (host (send entry get-host))
+ (tr-attr (if (send entry is-current?)
+ '((class "current"))
+ '((class "none"))))
+ )
+ (list 'tr (append (list (list 'id (format "~a" id)))
+ tr-attr)
+ (list 'td (list '(class "name")) name)
+ (list 'td (list '(class "kind"))
+ (tr kind))
+ (list 'td '((class "path"))
+ (format "~a" local-path))
+ (list 'td '((class "host"))
+ (or host ""))))
+ (f (+ i 1)))))))
+ (let* ((tbl (f 0))
+ (el (send this element 'lib-body))
+ (html (if (= count 0)
+ ""
+ (apply string-append (map xexpr->string tbl)))))
+ (displayln html)
+ (send el set-innerHTML! html)
+ (send this bind! "table.libraries tr" 'click
+ (lambda (el evt data)
+ (let* ((new-id (string->symbol (send el attr 'id)))
+ (new-lib (send libs get-library new-id))
+ (cur-lib (send libs current-library))
+ )
+ (displayln new-id)
+ (displayln new-lib)
+ (displayln cur-lib)
+ (unless (eq? cur-lib #f)
+ (let ((cur-el (send this element (send cur-lib get-id))))
+ (send cur-el remove-class! 'current)
+ (send cur-lib set-current! #f)))
+ (unless (eq? new-id #f)
+ (let ((new-el (send this element new-id)))
+ (displayln new-el)
+ (displayln (send new-el attr 'id))
+ (send new-el set-attr! '(test "NEE!"))
+ (send new-el add-class! "current")
+ (send new-lib set-current! #t)))
+ (libraries-changed-callback)
+ )))
+ ))))
+
+ (define/public (add-library)
+ (let* ((cb (λ (id name kind root host item-limit)
+ (send libs add-library
+ (library-item
+ id
+ name
+ kind
+ 1
+ root
+ (if (string=? host "")
+ #f
+ host)
+ item-limit
+ #f))
+ (send this update-libraries)
+ (libraries-changed-callback)))
+ (dlg (new library-dlg% [parent this]
+ [settings (send settings clone 'library-dlg)]
+ [kind 'filesystem] [result-cb cb])))
+ (send dlg show)))
+
+ (define/public (edit-library)
+ (let ((entry
+ (send libs current-library)))
+ (when entry
+ (let* ((id (send entry get-id))
+ (kind (send entry get-kind))
+ (kind-version
+ (send entry get-kind-version))
+ (current
+ (send entry is-current?))
+ (cb
+ (lambda (id name kind root host item-limit)
+ (send libs
+ update-item!
+ (library-item
+ id
+ name
+ kind
+ kind-version
+ root
+ (if (string=? host "")
+ #f
+ host)
+ item-limit
+ current))
+ (send this update-libraries)
+ (libraries-changed-callback)))
+ (dlg
+ (new library-dlg%
+ [parent this]
+ [settings
+ (send settings
+ clone
+ 'library-dlg)]
+ [id id]
+ [name
+ (send entry get-name)]
+ [kind kind]
+ [kind-editable? #f]
+ [local-path
+ (format
+ "~a"
+ (send entry get-root))]
+ [host
+ (or
+ (send entry get-host)
+ "")]
+ [item-limit
+ (send entry get-item-limit)]
+ [result-cb cb])))
+ (send dlg show)))))
+
+ (define/public (remove-library)
+ (let ((entry
+ (send libs current-library)))
+ (when entry
+ (send libs
+ remove-library
+ (send entry get-id))
+ (let ((new-current
+ (send libs current-library)))
+ (when new-current
+ (send new-current
+ set-current!
+ #t)))
+ (libraries-changed-callback)
+ (send this update-libraries))))
+
+ (define/override (page-loaded oke)
+ (unless initialized
+ (when oke
+ (set! initialized #t)
+ (set! btn-ok (send this element 'ok))
+ (set! btn-cancel (send this element 'cancel))
+ (set! btn-add (send this element 'add))
+ (set! btn-edit (send this element 'edit))
+ (set! btn-remove (send this element 'remove))
+ (set! btn-clear-cache
+ (send this element 'clear-cache))
+ (set! lbl-language (send this element 'lbl-language))
+ (set! lbl-lib (send this element 'lbl-libary-path))
+ (set! lbl-renderers
+ (send this element 'lbl-renderers))
+ (set! lbl-renderer-name
+ (send this element 'lbl-renderer-name))
+ (set! lbl-volume-curve
+ (send this element 'lbl-volume-curve))
+ (set! renderer-body
+ (send this element 'renderer-body))
+ (set! lbl-name (send this element 'lbl-name))
+ (set! lbl-kind (send this element 'lbl-kind))
+ (set! lbl-local-path (send this element 'lbl-local-path))
+ (set! lbl-host (send this element 'lbl-host))
+ (set! div-language (send this element 'language))
+
+ (send this set-labels)
+
+ (send div-language set-innerHTML! (make-select-list 'sel-lang (languages) (current-lang)))
+
+ (send this bind! 'sel-lang 'change (λ (el evt data)
+ (let ((lang (string->symbol
+ (format "~a" (hash-ref data 'value (current-lang))))))
+ (set-lang! lang)
+ (send cfg set! 'language lang)
+ (send this set-labels))))
+
+ (send this bind! 'ok 'click (λ (el evt data) (send this close)))
+ (send this bind! 'cancel 'click (λ (el evt data) (send this close)))
+ (send this bind! 'dev 'click (λ args (send this devtools)))
+ (send this bind! 'add 'click (λ (el evt data) (send this add-library)))
+ (send this bind! 'edit 'click (λ (el evt data) (send this edit-library)))
+ (send this bind! 'remove 'click (λ (el evt data) (send this remove-library)))
+ (send this bind!
+ 'clear-cache
+ 'click
+ (lambda (el evt data)
+ (cache-cleared-callback)))
+
+ (send this update-libraries)
+ (send this update-renderers)
+ )
+ )
+ (info-rktplayer "page loaded")
+ )
+
+ (begin
+ #t)
+ )
+ )
diff --git a/translate.rkt b/gui/translate.rkt
similarity index 68%
rename from translate.rkt
rename to gui/translate.rkt
index 474a824..23cc10d 100644
--- a/translate.rkt
+++ b/gui/translate.rkt
@@ -148,6 +148,9 @@
('paused
('en "paused")
('nl "gepauzeerd"))
+ ('starting
+ ('en "starting")
+ ('nl "starten"))
('unknown-state
('en "Unknown state")
('nl "Onbekende status"))
@@ -184,6 +187,36 @@
('bits
('en "bits")
('nl "bits"))
+ ('source
+ ('en "Source")
+ ('nl "Bron"))
+ ('downloading-track
+ ('en "downloading track ~a: ~a%")
+ ('nl "downloaden track ~a : ~a%"))
+ ('download-trackcomplete
+ ('en "track ~a downloaded")
+ ('nl "track ~a gedownload"))
+ ('download-track-failed
+ ('en "track ~a - download failed")
+ ('nl "track ~a - download mislukt"))
+ ('playback-failed
+ ('en "Could not play: ~a")
+ ('nl "Afspelen mislukt: ~a"))
+ ('renderer-unreachable
+ ('en "Player not reachable: ~a")
+ ('nl "Speler niet bereikbaar: ~a"))
+ ('renderer-command-failed
+ ('en "Player command failed: ~a")
+ ('nl "Opdracht aan speler mislukt: ~a"))
+ ('clear-cache
+ ('en "Clear downloaded tracks")
+ ('nl "Verwijder gedownloade tracks"))
+ ('renderers
+ ('en "Audio Players")
+ ('nl "Muziekspelers"))
+ ('logarithmic-volume
+ ('en "Logarithmic volume")
+ ('nl "Logaritmisch volume"))
('play
('en "Play")
('nl "Afspelen"))
@@ -212,6 +245,48 @@
('en "Search DLNA Players on network")
('nl "Zoek DLNA Spelers op het netwerk"))
('players
- ('en "Audio Players")
- ('nl "Muziek Spelers"))
+ ('en "Audio Players")
+ ('nl "Muziek Spelers"))
+ ('libraries
+ ('en "Music Libraries")
+ ('nl "Muziekbibliotheken"))
+ ('library-kind
+ ('en "Library type")
+ ('nl "Bibliotheektype"))
+ ('filesystem
+ ('en "Filesystem")
+ ('nl "Bestandssysteem"))
+ ('media-server
+ ('en "UPnP media server")
+ ('nl "UPnP-mediaserver"))
+ ('media-servers
+ ('en "Media server")
+ ('nl "Mediaserver"))
+ ('media-server-root
+ ('en "Start point")
+ ('nl "Startpunt"))
+ ('media-server-item-limit
+ ('en "Maximum items per folder")
+ ('nl "Maximum aantal items per map"))
+ ('select-media-server-container
+ ('en "Select a folder")
+ ('nl "Selecteer een map"))
+ ('no-media-server-containers
+ ('en "No folders")
+ ('nl "Geen mappen"))
+ ('up
+ ('en "Up")
+ ('nl "Omhoog"))
+ ('refresh
+ ('en "Refresh")
+ ('nl "Vernieuwen"))
+ ('searching
+ ('en "Searching...")
+ ('nl "Zoeken..."))
+ ('no-media-servers
+ ('en "No media servers found")
+ ('nl "Geen mediaservers gevonden"))
+ ('library-browse-failed
+ ('en "Could not open music library: ~a")
+ ('nl "Muziekbibliotheek kon niet worden geopend: ~a"))
)
diff --git a/tray.rkt b/gui/tray.rkt
similarity index 97%
rename from tray.rkt
rename to gui/tray.rkt
index 56f6307..fbc254a 100644
--- a/tray.rkt
+++ b/gui/tray.rkt
@@ -3,12 +3,12 @@
(require racket-webview
racket/runtime-path
"translate.rkt"
- "utils.rkt"
+ "../misc/utils.rkt"
)
(provide rktplayer-tray%)
-(define-runtime-path rkt-gui-dir "gui")
+(define-runtime-path rkt-gui-dir "html")
(define rktplayer-tray%
(class wv-tray%
@@ -76,4 +76,4 @@
)
)
- )
\ No newline at end of file
+ )
diff --git a/info.rkt b/info.rkt
index 001943d..bdfa308 100644
--- a/info.rkt
+++ b/info.rkt
@@ -2,7 +2,7 @@
(define pkg-authors '(hnmdijkema))
-(define version "0.1.1")
+(define version "0.1.2")
(define license 'MIT)
(define collection "rktplayer")
(define pkg-desc "rktplayer - A music player written in racket")
@@ -12,6 +12,10 @@
'("racket/gui" "racket/base" "racket"
"finalizer" "draw-lib" "net-lib"
"simple-log" "simple-ini" "racket-sprintf"
+ "racket-mimetypes"
+ "racket-upnp"
+ "racket-sonos"
+ "racket-audio-dlna"
"early-return" "let-assert"
"uni-channel" "port-channel"
"rackunit-lib"
@@ -26,5 +30,3 @@
))
(define test-omit-paths 'all)
-
-
diff --git a/libraries.rkt b/libraries.rkt
deleted file mode 100644
index 4f3c2f0..0000000
--- a/libraries.rkt
+++ /dev/null
@@ -1,125 +0,0 @@
-#lang racket/base
-
-(require racket/class
- "utils.rkt"
- )
-
-(provide libraries%
- library%
- )
-
-
-(define library%
- (class object%
- (init-field [id (new-id)] [name ""] [local-path ""]
- [host ""] [prefixes ""] [current #f])
- (super-new)
-
- (define/public (get-id) id)
- (define/public (get-name) name)
- (define/public (get-local-path) local-path)
- (define/public (get-host) host)
- (define/public (get-prefixes) prefixes)
- (define/public (is-current?) current)
- (define/public (get-current) current)
- (define/public (set-current! c) (set! current c))
- (define/public (->list)
- (list id name local-path host prefixes current))
- ))
-
-
-(define libraries%
- (class object%
- (init-field [settings settings])
- (super-new)
-
- (define libs #f)
-
- (define cfg (send settings clone 'settings))
-
- (define (to-library e)
- (let ((f (lambda (id n lp h p . c)
- (let ((cc (if (null? c) #f (car c))))
- (new library% [id id]
- [name n] [local-path lp]
- [host h] [prefixes p] [current cc])
- ))))
- (apply f e)
- )
- )
-
- (define (from-library l)
- (send l ->list))
-
- (define/public (libraries)
- (when (eq? libs #f)
- (let ((cfg-libs (send cfg get 'libraries '())))
- (dbg-rktplayer "libraries from ini: ~a" cfg-libs)
- (set! libs (sort (map to-library cfg-libs)
- (lambda (a b)
- (string= idx 0) (< idx (length libs)))
- (send (list-ref libs idx) get-id)
- #f)))
-
- (define/public (get-library id)
- (let ((libs (send this libraries)))
- (letrec ((f (λ (libs)
- (if (null? libs)
- #f
- (let* ((lib (car libs))
- (lib-id (send lib get-id)))
- (dbg-rktplayer "symbol? lib-id: ~a, lib-id: ~a (~a) eq? ~a" (symbol? lib-id) lib-id (send lib get-name) id)
- (if (eq? lib-id id)
- lib
- (f (cdr libs))))))))
- (f libs))))
-
- (define/public (remove-library id)
- (let ((libs (send this libraries)))
- (send this set-libraries! (filter (λ (lib)
- (not (eq? (send lib get-id) id)))
- libs))))
-
- (define/public (add-library l)
- (let ((libs (send this libraries)))
- (send this set-libraries! (cons l libs))
- (set! libs #f)
- (send l get-id)))
-
- (define/public (update-library l)
- (let ((libs (send this libraries))
- (id (send l get-id)))
- (send this set-libraries! (map (λ (lib)
- (if (eq? (send lib get-id) id)
- l
- lib))
- libs))))
-
- (define/public (current-library)
- (letrec ((f (lambda (libs)
- (if (null? libs)
- (if (= (send this count) 0)
- #f (send this get-library
- (send this library-id 0)))
- (let ((l (car libs)))
- (if (send l is-current?)
- l
- (f (cdr libs))))))
- ))
- (f (send this libraries))))
-
- ))
\ No newline at end of file
diff --git a/library/base/booklet-provider.rkt b/library/base/booklet-provider.rkt
new file mode 100644
index 0000000..1d15113
--- /dev/null
+++ b/library/base/booklet-provider.rkt
@@ -0,0 +1,12 @@
+#lang racket/base
+
+(require racket/class)
+
+(provide booklet-provider%)
+
+(define booklet-provider%
+ (class object%
+ (abstract
+ has-booklet?
+ booklet-file)
+ (super-new)))
diff --git a/library/base/image-provider.rkt b/library/base/image-provider.rkt
new file mode 100644
index 0000000..411b92f
--- /dev/null
+++ b/library/base/image-provider.rkt
@@ -0,0 +1,13 @@
+#lang racket/base
+
+(require racket/class)
+
+(provide image-provider%)
+
+(define image-provider%
+ (class object%
+ (abstract
+ has-image?
+ image->file
+ image->mimetype)
+ (super-new)))
diff --git a/library/base/media-container.rkt b/library/base/media-container.rkt
new file mode 100644
index 0000000..a72ac5b
--- /dev/null
+++ b/library/base/media-container.rkt
@@ -0,0 +1,52 @@
+#lang racket/base
+
+(require racket/class
+ "media-item.rkt")
+
+(provide media-container%)
+
+;; A media container contains media-item% instances. An item can itself be
+;; another media-container%, or it can be a track<%>.
+(define media-container%
+ (class media-item%
+ (init [id #f])
+
+ (super-new
+ [id id]
+ [kind 'container])
+
+ (abstract
+ get-title
+ get-items
+ get-track-reliver)))
+
+(module+ test
+ (require rackunit)
+
+ (define track-reliver
+ (lambda (track-factory-id track-relive-info)
+ (list track-factory-id track-relive-info)))
+
+ (define test-container%
+ (class media-container%
+ (super-new [id 'container-id])
+
+ (define/override (get-title)
+ "Container")
+
+ (define/override (get-items)
+ '())
+
+ (define/override (get-track-reliver)
+ track-reliver)))
+
+ (define container
+ (new test-container%))
+
+ (check-equal? (send container get-id) 'container-id)
+ (check-equal? (send container get-kind) 'container)
+ (check-eq? (send container get-container) container)
+ (check-false (send container get-track))
+ (check-equal? (send container get-title) "Container")
+ (check-equal? (send container get-items) '())
+ (check-eq? (send container get-track-reliver) track-reliver))
diff --git a/library/base/media-item.rkt b/library/base/media-item.rkt
new file mode 100644
index 0000000..cb6dea5
--- /dev/null
+++ b/library/base/media-item.rkt
@@ -0,0 +1,59 @@
+#lang racket/base
+
+(require racket/class)
+
+(provide media-item%)
+
+;; Common base class for entries returned by a media container.
+(define media-item%
+ (class object%
+ (init-field
+ kind
+ [id #f])
+
+ (unless (memq kind '(container track))
+ (raise-arguments-error
+ 'media-item%
+ "invalid media item kind"
+ "expected" '(container track)
+ "kind" kind))
+
+ (define/public (get-id)
+ id)
+
+ (define/public (get-kind)
+ kind)
+
+ (define/public (get-container)
+ (and (eq? kind 'container)
+ this))
+
+ (define/public (get-track)
+ (and (eq? kind 'track)
+ this))
+
+ (super-new)))
+
+(module+ test
+ (require rackunit)
+
+ (define container
+ (new media-item%
+ [id 'container-id]
+ [kind 'container]))
+
+ (define track
+ (new media-item%
+ [id 'track-id]
+ [kind 'track]))
+
+ (check-eq? (send container get-container) container)
+ (check-false (send container get-track))
+ (check-eq? (send track get-track) track)
+ (check-false (send track get-container))
+ (check-equal? (send container get-id) 'container-id)
+ (check-equal? (send track get-kind) 'track)
+ (check-exn
+ exn:fail:contract?
+ (lambda ()
+ (new media-item% [kind 'unknown]))))
diff --git a/library/base/media-library.rkt b/library/base/media-library.rkt
new file mode 100644
index 0000000..bc3c865
--- /dev/null
+++ b/library/base/media-library.rkt
@@ -0,0 +1,51 @@
+#lang racket/base
+
+(require racket/class
+ "../library-cfg.rkt"
+ "../../misc/utils.rkt")
+
+(provide media-library%)
+
+(define media-library%
+ (class object%
+ (init-field
+ cfg)
+
+ (check/c media-library%
+ cfg
+ (is-a?/c library-cfg%))
+
+ (define cfg-revision
+ -1)
+
+ (define root-container
+ #f)
+
+ (define/private (reset-if-needed!)
+ (let ((current-revision (send cfg get-revision)))
+ (unless (= cfg-revision current-revision)
+ (set! cfg-revision current-revision)
+ (set! root-container #f))))
+
+ (define/public (get-cfg)
+ cfg)
+
+ (define/public (get-id)
+ (send cfg get-id))
+
+ (define/public (get-kind)
+ (send cfg get-kind))
+
+ (define/public (get-kind-version)
+ (send cfg get-kind-version))
+
+ (define/public (get-root-container)
+ (reset-if-needed!)
+ (when (eq? root-container #f)
+ (set! root-container
+ (send this make-root-container)))
+ root-container)
+
+ (abstract make-root-container)
+
+ (super-new)))
diff --git a/library/base/media-resource.rkt b/library/base/media-resource.rkt
new file mode 100644
index 0000000..0917693
--- /dev/null
+++ b/library/base/media-resource.rkt
@@ -0,0 +1,97 @@
+#lang racket/base
+
+(require net/url
+ racket/class
+ racket/string
+ "../../misc/utils.rkt")
+
+(provide media-resource%
+ media-resource-file%)
+
+(define media-resource%
+ (class object%
+ (init-field
+ uri
+ mime-type
+ protocol-info
+ seekable?)
+
+ (check/c* media-resource%
+ (uri string?)
+ (mime-type (or/c #f string?))
+ (protocol-info (or/c #f string?))
+ (seekable? boolean?))
+
+ (define/public (get-uri)
+ uri)
+
+ (define/public (get-mime-type)
+ mime-type)
+
+ (define/public (get-protocol-info)
+ protocol-info)
+
+ (define/public (is-seekable?)
+ seekable?)
+
+ (define/public (get-file)
+ #f)
+
+ (super-new)))
+
+(define media-resource-file%
+ (class media-resource%
+ (init
+ file
+ mime-type
+ [seekable? #t])
+
+ (check/c media-resource-file%
+ file
+ (or/c path? string?))
+
+ (define resource-file
+ (normal-case-path
+ (path->complete-path file)))
+
+ (define/override (get-file)
+ resource-file)
+
+ (super-new
+ [uri
+ (url->string
+ (path->url resource-file))]
+ [mime-type mime-type]
+ [protocol-info
+ (and mime-type
+ (format "file:*:~a:*" mime-type))]
+ [seekable? seekable?])))
+
+(module+ test
+ (require rackunit)
+
+ (define resource
+ (new media-resource-file%
+ [file
+ (build-path
+ (find-system-path 'temp-dir)
+ "track.flac")]
+ [mime-type "audio/flac"]))
+
+ (check-true
+ (is-a? resource media-resource%))
+ (check-true
+ (is-a? resource media-resource-file%))
+ (check-true
+ (path? (send resource get-file)))
+ (check-true
+ (string-prefix? (send resource get-uri)
+ "file:"))
+ (check-equal?
+ (send resource get-mime-type)
+ "audio/flac")
+ (check-equal?
+ (send resource get-protocol-info)
+ "file:*:audio/flac:*")
+ (check-true
+ (send resource is-seekable?)))
diff --git a/library/base/tag-data-provider.rkt b/library/base/tag-data-provider.rkt
new file mode 100644
index 0000000..061d064
--- /dev/null
+++ b/library/base/tag-data-provider.rkt
@@ -0,0 +1,10 @@
+#lang racket/base
+
+(require racket/class)
+
+(provide tag-data-provider%)
+
+(define tag-data-provider%
+ (class object%
+ (abstract get-tag-data)
+ (super-new)))
diff --git a/library/base/track.rkt b/library/base/track.rkt
new file mode 100644
index 0000000..71292d6
--- /dev/null
+++ b/library/base/track.rkt
@@ -0,0 +1,205 @@
+#lang racket/base
+
+(require racket/class
+ "booklet-provider.rkt"
+ "image-provider.rkt"
+ "media-item.rkt"
+ "media-resource.rkt"
+ "tag-data-provider.rkt"
+ "../track-tag-data.rkt"
+ "../../misc/utils.rkt")
+
+(provide track<%>
+ track%)
+
+(define track<%>
+ (interface ((class->interface media-item%))
+ get-title
+ get-artist
+ get-album
+ get-number
+ get-length
+ get-resource
+ get-music-library-factory-id
+ get-track-factory-id
+ get-track-relive-info
+ has-image?
+ image->file
+ image->mimetype
+ has-booklet?
+ booklet-file
+ track<
+ ->log))
+
+(define next-track-id
+ 0)
+
+(define (new-track-id)
+ (set! next-track-id (+ next-track-id 1))
+ (when (> next-track-id 10000000)
+ (set! next-track-id 1))
+ next-track-id)
+
+(define track%
+ (class* media-item% (track<%>)
+ (init
+ tag-data-provider
+ image-provider
+ booklet-provider
+ resource
+ [id #f]
+ [music-library-factory-id #f]
+ [track-factory-id #f]
+ [track-relive-info #f])
+
+ (check/c* track%
+ (tag-data-provider
+ (is-a?/c tag-data-provider%))
+ (image-provider
+ (is-a?/c image-provider%))
+ (booklet-provider
+ (is-a?/c booklet-provider%))
+ (resource
+ (is-a?/c media-resource%)))
+
+ (define the-tag-data-provider
+ tag-data-provider)
+
+ (define the-image-provider
+ image-provider)
+
+ (define the-booklet-provider
+ booklet-provider)
+
+ (define the-resource
+ resource)
+
+ (define the-music-library-factory-id
+ music-library-factory-id)
+
+ (define the-track-factory-id
+ track-factory-id)
+
+ (define the-track-relive-info
+ track-relive-info)
+
+ (define/private (get-tag-data)
+ (send the-tag-data-provider get-tag-data))
+
+ (define/public (get-title)
+ (track-tag-data-title (get-tag-data)))
+
+ (define/public (get-artist)
+ (track-tag-data-artist (get-tag-data)))
+
+ (define/public (get-album)
+ (track-tag-data-album (get-tag-data)))
+
+ (define/public (get-number)
+ (track-tag-data-number (get-tag-data)))
+
+ (define/public (get-length)
+ (track-tag-data-length (get-tag-data)))
+
+ (define/public (get-resource)
+ the-resource)
+
+ (define/public (get-music-library-factory-id)
+ the-music-library-factory-id)
+
+ (define/public (get-track-factory-id)
+ the-track-factory-id)
+
+ (define/public (get-track-relive-info)
+ the-track-relive-info)
+
+ (define/public (has-image?)
+ (send the-image-provider has-image?))
+
+ (define/public (image->file target-file)
+ (send the-image-provider image->file target-file))
+
+ (define/public (image->mimetype)
+ (send the-image-provider image->mimetype))
+
+ (define/public (has-booklet?)
+ (send the-booklet-provider has-booklet?))
+
+ (define/public (booklet-file)
+ (send the-booklet-provider booklet-file))
+
+ (define/public (track< other-track)
+ (if (string-cilog)
+ (info-rktplayer "~a - ~a - ~a - ~a"
+ (send this get-number)
+ (send this get-title)
+ (send this get-album)
+ (send this get-length)))
+
+ (super-new
+ [id (if id id (new-track-id))]
+ [kind 'track])))
+
+(module+ test
+ (require rackunit)
+
+ (define test-tag-data-provider%
+ (class tag-data-provider%
+ (define/override (get-tag-data)
+ (track-tag-data
+ "Title"
+ "Artist"
+ "Album"
+ 2
+ 120))
+ (super-new)))
+
+ (define test-image-provider%
+ (class image-provider%
+ (define/override (has-image?) #f)
+ (define/override (image->file target-file) #f)
+ (define/override (image->mimetype) 'no-mimetype)
+ (super-new)))
+
+ (define test-booklet-provider%
+ (class booklet-provider%
+ (define/override (has-booklet?) #f)
+ (define/override (booklet-file) #f)
+ (super-new)))
+
+ (define resource
+ (new media-resource%
+ [uri "https://example.com/track.flac"]
+ [mime-type "audio/flac"]
+ [protocol-info "http-get:*:audio/flac:*"]
+ [seekable? #t]))
+
+ (define track
+ (new track%
+ [resource resource]
+ [tag-data-provider
+ (new test-tag-data-provider%)]
+ [image-provider
+ (new test-image-provider%)]
+ [booklet-provider
+ (new test-booklet-provider%)]))
+
+ (check-true (is-a? track track%))
+ (check-true (is-a? track track<%>))
+ (check-equal? (send track get-kind) 'track)
+ (check-equal? (send track get-title) "Title")
+ (check-equal? (send track get-artist) "Artist")
+ (check-equal? (send track get-album) "Album")
+ (check-equal? (send track get-number) 2)
+ (check-equal? (send track get-length) 120)
+ (check-eq? (send track get-resource) resource)
+ (check-false (send track has-image?))
+ (check-false (send track has-booklet?)))
diff --git a/library/libraries-config.rkt b/library/libraries-config.rkt
new file mode 100644
index 0000000..65661e9
--- /dev/null
+++ b/library/libraries-config.rkt
@@ -0,0 +1,149 @@
+#lang racket/base
+
+(require racket/class
+ "library-cfg.rkt"
+ "library-item.rkt"
+ "../misc/utils.rkt")
+
+(provide libraries-config%
+ (all-from-out "library-cfg.rkt")
+ (all-from-out "library-item.rkt"))
+
+(define libraries-config%
+ (class object%
+ (init-field settings)
+
+ (define items
+ #f)
+
+ (define revisions
+ (make-hash))
+
+ (define cfg
+ (send settings clone 'settings))
+
+ (define/private (sorted-items value)
+ (sort value
+ (lambda (a b)
+ (stringlibrary-item stored)))))
+ items)
+
+ (define/private (store-items! value)
+ (let ((new-items (sorted-items value)))
+ (send cfg
+ set!
+ 'libraries
+ (map library-item->store new-items))
+ (set! items new-items)))
+
+ (define/private (increment-revision! id)
+ (hash-update! revisions id add1 0))
+
+ (define/public (libraries)
+ (map (lambda (item)
+ (new library-cfg%
+ [library-cfg-id (library-item-id item)]
+ [libraries-config this]))
+ (get-items)))
+
+ (define/public (count)
+ (length (get-items)))
+
+ (define/public (library-id idx)
+ (let ((all-items (get-items)))
+ (if (and (>= idx 0)
+ (< idx (length all-items)))
+ (library-item-id (list-ref all-items idx))
+ #f)))
+
+ (define/public (get-item id)
+ (check/c libraries-config% get-item id symbol?)
+ (findf (lambda (item)
+ (eq? (library-item-id item) id))
+ (get-items)))
+
+ (define/public (get-item-revision id)
+ (check/c libraries-config% get-item-revision id symbol?)
+ (hash-ref revisions id 0))
+
+ (define/public (get-library id)
+ (check/c libraries-config% get-library id symbol?)
+ (and (send this get-item id)
+ (new library-cfg%
+ [library-cfg-id id]
+ [libraries-config this])))
+
+ (define/public (remove-library id)
+ (check/c libraries-config% remove-library id symbol?)
+ (store-items!
+ (filter (lambda (item)
+ (not (eq? (library-item-id item) id)))
+ (get-items)))
+ (increment-revision! id))
+
+ (define/public (add-library item)
+ (check/c libraries-config% add-library item library-item?)
+
+ (let ((id (library-item-id item)))
+ (when (send this get-item id)
+ (raise-arguments-error
+ 'libraries-config%:add-library
+ "a library with this id already exists"
+ "id" id))
+
+ (store-items! (cons item (get-items)))
+ (increment-revision! id)
+ id))
+
+ (define/public (update-item! item)
+ (check/c libraries-config% update-item! item library-item?)
+
+ (let* ((id (library-item-id item))
+ (current-item (send this get-item id)))
+ (unless current-item
+ (raise-arguments-error
+ 'libraries-config%:update-item!
+ "library does not exist"
+ "id" id))
+
+ (unless (and (eq? (library-item-kind current-item)
+ (library-item-kind item))
+ (= (library-item-kind-version current-item)
+ (library-item-kind-version item)))
+ (raise-arguments-error
+ 'libraries-config%:update-item!
+ "library kind and kind-version cannot be changed"
+ "id" id))
+
+ (store-items!
+ (map (lambda (existing)
+ (if (eq? (library-item-id existing) id)
+ item
+ existing))
+ (get-items)))
+ (increment-revision! id)
+ (void)))
+
+ (define/public (current-library)
+ (let ((item
+ (findf library-item-current
+ (get-items))))
+ (if item
+ (send this get-library
+ (library-item-id item))
+ (if (null? (get-items))
+ #f
+ (send this get-library
+ (library-item-id
+ (car (get-items))))))))
+
+ (super-new)))
diff --git a/library/library-browser.rkt b/library/library-browser.rkt
new file mode 100644
index 0000000..39a31e8
--- /dev/null
+++ b/library/library-browser.rkt
@@ -0,0 +1,82 @@
+#lang racket/base
+
+(require racket/class
+ "base/media-container.rkt"
+ "base/media-library.rkt"
+ "../misc/utils.rkt")
+
+(provide library-browser%)
+
+(define library-browser%
+ (class object%
+ (init-field media-library)
+
+ (check/c library-browser%
+ media-library
+ (is-a?/c media-library%))
+
+ (define current-container
+ #f)
+
+ (define parent-containers
+ '())
+
+ (define cfg-revision
+ -1)
+
+ (define/private (reset-if-needed!)
+ (let ((current-revision
+ (send (send media-library get-cfg)
+ get-revision)))
+ (unless (= cfg-revision current-revision)
+ (set! cfg-revision current-revision)
+ (send this reset!))))
+
+ (define/public (get-media-library)
+ media-library)
+
+ (define/public (get-current-container)
+ (reset-if-needed!)
+ current-container)
+
+ (define/public (get-items)
+ (send (send this get-current-container)
+ get-items))
+
+ (define/public (can-go-up?)
+ (reset-if-needed!)
+ (not (null? parent-containers)))
+
+ (define/public (open-container! container)
+ (check/c library-browser% open-container!
+ container
+ (is-a?/c media-container%))
+
+ (reset-if-needed!)
+ (set! parent-containers
+ (cons current-container
+ parent-containers))
+ (set! current-container container)
+ (void))
+
+ (define/public (go-up!)
+ (reset-if-needed!)
+ (unless (null? parent-containers)
+ (set! current-container
+ (car parent-containers))
+ (set! parent-containers
+ (cdr parent-containers)))
+ (void))
+
+ (define/public (reset!)
+ (set! cfg-revision
+ (send (send media-library get-cfg)
+ get-revision))
+ (set! current-container
+ (send media-library get-root-container))
+ (set! parent-containers '())
+ (void))
+
+ (super-new)
+
+ (send this reset!)))
diff --git a/library/library-cfg.rkt b/library/library-cfg.rkt
new file mode 100644
index 0000000..6181e06
--- /dev/null
+++ b/library/library-cfg.rkt
@@ -0,0 +1,71 @@
+#lang racket/base
+
+(require racket/class
+ "library-item.rkt"
+ "../misc/utils.rkt")
+
+(provide library-cfg%)
+
+(define library-cfg%
+ (class object%
+ (init-field
+ library-cfg-id
+ libraries-config)
+
+ (check/c* library-cfg%
+ (library-cfg-id symbol?)
+ (libraries-config object?))
+
+ (define/private (get-item)
+ (let ((item (send libraries-config
+ get-item
+ library-cfg-id)))
+ (unless item
+ (raise-arguments-error
+ 'library-cfg%
+ "library configuration no longer exists"
+ "library-cfg-id" library-cfg-id))
+ item))
+
+ (define/public (get-id)
+ library-cfg-id)
+
+ (define/public (get-name)
+ (library-item-name (get-item)))
+
+ (define/public (get-kind)
+ (library-item-kind (get-item)))
+
+ (define/public (get-kind-version)
+ (library-item-kind-version (get-item)))
+
+ (define/public (get-root)
+ (library-item-root (get-item)))
+
+ (define/public (get-host)
+ (library-item-host (get-item)))
+
+ (define/public (get-item-limit)
+ (library-item-item-limit (get-item)))
+
+ (define/public (is-current?)
+ (library-item-current (get-item)))
+
+ (define/public (get-current)
+ (library-item-current (get-item)))
+
+ (define/public (get-revision)
+ (send libraries-config
+ get-item-revision
+ library-cfg-id))
+
+ (define/public (set-current! value)
+ (check/c library-cfg% set-current! value boolean?)
+
+ (send libraries-config
+ update-item!
+ (struct-copy library-item
+ (get-item)
+ [current value])))
+
+ (super-new)))
diff --git a/library/library-factory.rkt b/library/library-factory.rkt
new file mode 100644
index 0000000..8b7d2ba
--- /dev/null
+++ b/library/library-factory.rkt
@@ -0,0 +1,108 @@
+#lang racket/base
+
+(require racket/class
+ "libraries-config.rkt"
+ "base/media-library.rkt"
+ "../misc/utils.rkt")
+
+(provide library-factory%
+ get-library-factory
+ set-library-factory!)
+
+(define current-library-factory
+ #f)
+
+(define (get-library-factory)
+ (unless current-library-factory
+ (raise-arguments-error
+ 'get-library-factory
+ "no library factory has been configured"))
+ current-library-factory)
+
+(define (set-library-factory! factory)
+ (check/c set-library-factory!
+ factory
+ (is-a?/c library-factory%))
+ (set! current-library-factory factory)
+ (void))
+
+(define library-factory%
+ (class object%
+ (init-field libraries-config)
+
+ (check/c library-factory%
+ libraries-config
+ (is-a?/c libraries-config%))
+
+ (define makers
+ (make-hash))
+
+ (define libraries
+ (make-hash))
+
+ (define/public (get-libraries-config)
+ libraries-config)
+
+ (define/public (register-library-maker! kind version maker)
+ (check/c* (library-factory% register-library-maker!)
+ (kind symbol?)
+ (version exact-positive-integer?)
+ (maker (-> (is-a?/c library-cfg%) any/c)))
+
+ (let ((maker-key (cons kind version)))
+ (when (hash-has-key? makers maker-key)
+ (raise-arguments-error
+ 'library-factory%:register-library-maker!
+ "a library maker is already registered"
+ "kind" kind
+ "version" version))
+
+ (hash-set! makers maker-key maker)
+ (void)))
+
+ (define/public (get-library library-id kind version)
+ (check/c* (library-factory% get-library)
+ (library-id symbol?)
+ (kind symbol?)
+ (version exact-positive-integer?))
+
+ (hash-ref!
+ libraries
+ library-id
+ (lambda ()
+ (let ((cfg (send libraries-config
+ get-library
+ library-id)))
+ (unless cfg
+ (raise-arguments-error
+ 'library-factory%:get-library
+ "library configuration does not exist"
+ "library-id" library-id))
+
+ (unless (and (eq? kind (send cfg get-kind))
+ (= version (send cfg get-kind-version)))
+ (raise-arguments-error
+ 'library-factory%:get-library
+ "library kind or version does not match its configuration"
+ "library-id" library-id
+ "kind" kind
+ "version" version))
+
+ (let* ((maker-key (cons kind version))
+ (maker
+ (hash-ref
+ makers
+ maker-key
+ (lambda ()
+ (raise-arguments-error
+ 'library-factory%:get-library
+ "no library maker is registered"
+ "kind" kind
+ "version" version))))
+ (library (maker cfg)))
+ (check/c library-factory% get-library
+ library
+ (is-a?/c media-library%))
+ library)))))
+
+ (super-new)))
diff --git a/library/library-filesystem.rkt b/library/library-filesystem.rkt
new file mode 100644
index 0000000..4da995b
--- /dev/null
+++ b/library/library-filesystem.rkt
@@ -0,0 +1,66 @@
+#lang racket/base
+
+(require racket/class
+ "mc-filesystem.rkt"
+ "library-factory.rkt"
+ "base/media-library.rkt"
+ "track-filesystem.rkt"
+ "../misc/utils.rkt")
+
+(provide library-filesystem%
+ register-library-filesystem!)
+
+(define library-filesystem-kind
+ 'filesystem)
+
+(define library-filesystem-version
+ 1)
+
+(define (register-library-filesystem! factory)
+ (check/c register-library-filesystem!
+ factory
+ (is-a?/c library-factory%))
+
+ (send factory
+ register-library-maker!
+ library-filesystem-kind
+ library-filesystem-version
+ (lambda (cfg)
+ (new library-filesystem%
+ [cfg cfg]))))
+
+(define library-filesystem%
+ (class media-library%
+ (init
+ cfg)
+
+ (define/override (make-root-container)
+ (new mc-filesystem%
+ [library this]
+ [relative-path '()]))
+
+ (define/public (make-container relative-path)
+ (new mc-filesystem%
+ [library this]
+ [relative-path relative-path]))
+
+ (define/public (make-track relative-path)
+ (new track-filesystem%
+ [library this]
+ [relative-path relative-path]))
+
+ (define/public (resolve-path relative-path)
+ (check/c library-filesystem% resolve-path
+ relative-path
+ list?)
+
+ (let ((root
+ (normal-case-path
+ (send (send this get-cfg)
+ get-root))))
+ (if (null? relative-path)
+ root
+ (apply build-path root relative-path))))
+
+ (super-new
+ [cfg cfg])))
diff --git a/library/library-item.rkt b/library/library-item.rkt
new file mode 100644
index 0000000..1c79c20
--- /dev/null
+++ b/library/library-item.rkt
@@ -0,0 +1,74 @@
+#lang racket/base
+
+(require "../misc/utils.rkt")
+
+(provide
+ (struct-out library-item)
+ library-item->store
+ store->library-item)
+
+(define library-item-store-version
+ 1)
+
+(struct library-item
+ (id
+ name
+ kind
+ kind-version
+ root
+ host
+ item-limit
+ current)
+ #:transparent
+ #:guard
+ (lambda (id name kind kind-version root host item-limit current type-name)
+ (check/c* library-item
+ (id symbol?)
+ (name string?)
+ (kind (or/c 'filesystem 'media-server))
+ (kind-version exact-positive-integer?)
+ (root (or/c path? string?))
+ (host (or/c #f string?))
+ (item-limit exact-positive-integer?)
+ (current boolean?))
+ (values id
+ name
+ kind
+ kind-version
+ root
+ host
+ item-limit
+ current)))
+
+(define (library-item->store item)
+ (check/c library-item->store item library-item?)
+
+ (let ((root (library-item-root item)))
+ (hash
+ 'version library-item-store-version
+ 'id (library-item-id item)
+ 'name (library-item-name item)
+ 'kind (library-item-kind item)
+ 'kind-version (library-item-kind-version item)
+ 'root (if (path? root) (path->string root) root)
+ 'host (library-item-host item)
+ 'item-limit (library-item-item-limit item)
+ 'current (library-item-current item))))
+
+(define (store->library-item stored)
+ (check/c store->library-item stored hash?)
+
+ (let ((version (hash-ref stored 'version #f)))
+ (check/c store->library-item
+ version
+ (=/c library-item-store-version))
+
+ (library-item
+ (hash-ref stored 'id)
+ (hash-ref stored 'name)
+ (hash-ref stored 'kind)
+ (hash-ref stored 'kind-version)
+ (hash-ref stored 'root)
+ (hash-ref stored 'host)
+ (hash-ref stored 'item-limit 100)
+ (hash-ref stored 'current))))
diff --git a/library/library-media-server.rkt b/library/library-media-server.rkt
new file mode 100644
index 0000000..577cae3
--- /dev/null
+++ b/library/library-media-server.rkt
@@ -0,0 +1,219 @@
+#lang racket/base
+
+(require racket/class
+ racket/list
+ racket/match
+ racket/string
+ (prefix-in upnp: racket-upnp)
+ "library-factory.rkt"
+ "mc-media-server.rkt"
+ "base/media-library.rkt"
+ "track-media-server.rkt"
+ "../misc/utils.rkt")
+
+(provide library-media-server%
+ register-library-media-server!)
+
+(define library-media-server-kind
+ 'media-server)
+
+(define library-media-server-version
+ 1)
+
+(define (register-library-media-server! factory)
+ (check/c register-library-media-server!
+ factory
+ (is-a?/c library-factory%))
+
+ (send factory
+ register-library-maker!
+ library-media-server-kind
+ library-media-server-version
+ (lambda (cfg)
+ (new library-media-server%
+ [cfg cfg]))))
+
+(define library-media-server%
+ (class media-library%
+ (init
+ cfg)
+
+ (define server
+ #f)
+
+ (define server-cfg-revision
+ -1)
+
+ (define/private (server-selector)
+ (or (send (send this get-cfg)
+ get-host)
+ (send (send this get-cfg)
+ get-name)))
+
+ (define/private (server-matches? candidate selector)
+ (let ((name
+ (upnp:media-server-name candidate))
+ (address
+ (upnp:media-server-address candidate))
+ (udn
+ (upnp:upnp-device-udn candidate)))
+ (or
+ (and udn
+ (string-ci=? udn selector))
+ (and name
+ (string-ci=? name selector))
+ (and address
+ (string-ci=? address selector))
+ (and name
+ (string-contains?
+ (string-downcase name)
+ (string-downcase selector))))))
+
+ (define/private (get-server)
+ (let ((cfg-revision
+ (send (send this get-cfg)
+ get-revision)))
+ (unless (= cfg-revision
+ server-cfg-revision)
+ (set! server #f)
+ (set! server-cfg-revision
+ cfg-revision))
+ (unless server
+ (let* ((selector (server-selector))
+ (found
+ (findf
+ (lambda (candidate)
+ (server-matches?
+ candidate
+ selector))
+ (upnp:query-media-servers))))
+ (unless found
+ (raise-arguments-error
+ 'library-media-server%
+ "configured media server was not found"
+ "selector" selector))
+ (set! server found)))
+ server))
+
+ (define/private (root-container-id)
+ (format "~a"
+ (send (send this get-cfg)
+ get-root)))
+
+ (define/private (browse-page container-id start count)
+ (with-handlers
+ (((lambda (exception)
+ (and
+ (upnp:exn:fail:upnp? exception)
+ (equal?
+ (format "~a"
+ (upnp:exn:fail:upnp-code
+ exception))
+ "701")
+ (equal? container-id
+ (root-container-id))
+ (not (string=? container-id
+ "0"))))
+ (lambda (exception)
+ (warn-rktplayer
+ (string-append
+ "Configured UPnP media-server root ~a "
+ "does not exist; browsing root 0")
+ container-id)
+ (upnp:media-server-browse
+ (get-server)
+ "0"
+ #:start start
+ #:count count))))
+ (upnp:media-server-browse
+ (get-server)
+ container-id
+ #:start start
+ #:count count)))
+
+ (define/public (browse-container container-id)
+ (check/c library-media-server% browse-container
+ container-id
+ string?)
+
+ (browse-page
+ container-id
+ 0
+ (send (send this get-cfg)
+ get-item-limit)))
+
+ (define/private (find-entry parent-id entry-id)
+ (let ((page-size
+ (send (send this get-cfg)
+ get-item-limit)))
+ (let loop ((start 0))
+ (let* ((entries
+ (browse-page parent-id
+ start
+ page-size))
+ (entry
+ (findf
+ (lambda (candidate)
+ (equal?
+ (upnp:media-entry-id candidate)
+ entry-id))
+ entries)))
+ (cond
+ (entry entry)
+ ((< (length entries)
+ page-size)
+ #f)
+ (else
+ (loop (+ start
+ page-size))))))))
+
+ (define/override (make-root-container)
+ (new mc-media-server%
+ [library this]
+ [container-id
+ (root-container-id)]
+ [title
+ (send (send this get-cfg)
+ get-name)]))
+
+ (define/public (make-container entry)
+ (check/c library-media-server% make-container
+ entry
+ upnp:media-container?)
+
+ (new mc-media-server%
+ [library this]
+ [container-id
+ (upnp:media-entry-id entry)]
+ [title
+ (upnp:media-entry-title entry)]))
+
+ (define/public (make-track entry)
+ (check/c library-media-server% make-track
+ entry
+ upnp:media-item?)
+
+ (new track-media-server%
+ [library this]
+ [entry entry]))
+
+ (define/public (relive-track track-factory-id
+ track-relive-info)
+ (case track-factory-id
+ ((media-server-item)
+ (match track-relive-info
+ ((list (? string? parent-id)
+ (? string? entry-id))
+ (let ((entry
+ (find-entry parent-id
+ entry-id)))
+ (and entry
+ (upnp:media-item? entry)
+ (send this
+ make-track
+ entry))))
+ (else #f)))
+ (else #f)))
+
+ (super-new
+ [cfg cfg])))
diff --git a/library/library-ref.rkt b/library/library-ref.rkt
new file mode 100644
index 0000000..a4b2cb6
--- /dev/null
+++ b/library/library-ref.rkt
@@ -0,0 +1,7 @@
+#lang racket/base
+
+(provide (struct-out library-ref))
+
+(struct library-ref
+ (library-id kind version)
+ #:prefab)
diff --git a/library/mc-filesystem.rkt b/library/mc-filesystem.rkt
new file mode 100644
index 0000000..7c9dcae
--- /dev/null
+++ b/library/mc-filesystem.rkt
@@ -0,0 +1,82 @@
+#lang racket/base
+
+(require racket/class
+ racket-audio
+ racket/list
+ racket/path
+ racket/string
+ "base/media-container.rkt"
+ "../misc/utils.rkt")
+
+(provide mc-filesystem%)
+
+(define mc-filesystem%
+ (class media-container%
+ (init-field
+ library
+ [relative-path '()])
+
+ (check/c mc-filesystem% relative-path list?)
+
+ (define/private (full-path)
+ (send library resolve-path relative-path))
+
+ (define/private (music-file-name? path)
+ (let ((file-name
+ (string-downcase (path->string path))))
+ (for/or ((extension
+ (in-list (audio-known-exts?))))
+ (string-suffix?
+ file-name
+ (string-append "." extension)))))
+
+ (define/private (item-kind path)
+ (cond
+ ((directory-exists? path)
+ (let ((name
+ (path->string
+ (file-name-from-path path))))
+ (and (not (string-prefix? name "."))
+ 'container)))
+ ((music-file-name? path) 'track)
+ (else #f)))
+
+ (define/override (get-title)
+ (if (null? relative-path)
+ (send (send library get-cfg) get-name)
+ (path->string (last relative-path))))
+
+ (define/override (get-items)
+ (let ((path (full-path)))
+ (if (directory-exists? path)
+ (for*/list ((entry (in-list
+ (sort (directory-list path)
+ pathstring file)
+ file))
+ (source-tags (id3-tags source-file)))
+ (if (tags-valid? source-tags)
+ source-tags
+ (let ((temporary-file
+ (make-temporary-file
+ "rktplayer-~a"
+ #:copy-from source-file)))
+ (let ((temporary-tags
+ (id3-tags temporary-file)))
+ (delete-file temporary-file)
+ temporary-tags))))
+ #f))
+
+ (define/public (get-tags)
+ (unless loaded?
+ (set! tags (read-tags))
+ (set! loaded? #t))
+ tags)
+
+ (super-new)))
+
+(define tag-data-provider-filesystem%
+ (class tag-data-provider%
+ (init-field
+ tag-source
+ [fallback-data (track-tag-data "" "" "" 0 0)])
+
+ (define tag-data
+ #f)
+
+ (define/override (get-tag-data)
+ (unless tag-data
+ (let ((tags (send tag-source get-tags)))
+ (set! tag-data
+ (if (and tags (tags-valid? tags))
+ (track-tag-data
+ (tags-title tags)
+ (tags-artist tags)
+ (tags-album tags)
+ (tags-track tags)
+ (tags-length tags))
+ fallback-data))))
+ tag-data)
+
+ (super-new)))
+
+(define image-provider-filesystem%
+ (class image-provider%
+ (init-field file tag-source)
+
+ (define image-names
+ '("cover.jpg" "cover.png" "folder.jpg" "folder.png"))
+
+ (define/private (image-from-directory)
+ (and file
+ (let ((directory (path-only file)))
+ (for/first ((image-name (in-list image-names))
+ #:when
+ (file-exists?
+ (build-path directory image-name)))
+ (build-path directory image-name)))))
+
+ (define/override (has-image?)
+ (let ((tags (send tag-source get-tags)))
+ (or (and tags
+ (tags-valid? tags)
+ (not (eq? (tags-picture->ext tags) #f)))
+ (not (eq? (image-from-directory) #f)))))
+
+ (define/override (image->file target-file)
+ (let* ((target (format "~a" target-file))
+ (tags (send tag-source get-tags))
+ (picture-extension
+ (and tags
+ (tags-valid? tags)
+ (tags-picture->ext tags))))
+ (if picture-extension
+ (let ((stored-file
+ (string-append
+ target
+ "."
+ (symbol->string picture-extension))))
+ (and (tags-picture->file tags stored-file)
+ stored-file))
+ (let ((source-file (image-from-directory)))
+ (and source-file
+ (let ((stored-file
+ (string-append
+ target
+ (bytes->string/utf-8
+ (path-get-extension source-file)))))
+ (copy-file source-file
+ stored-file
+ #:exists-ok? #t)
+ (format "~a" stored-file)))))))
+
+ (define/override (image->mimetype)
+ (let ((tags (send tag-source get-tags)))
+ (if (and tags
+ (tags-valid? tags)
+ (not (eq? (tags-picture->ext tags) #f)))
+ (tags-picture->mimetype tags)
+ (let ((source-file (image-from-directory)))
+ (if source-file
+ (case (string->symbol
+ (string-downcase
+ (bytes->string/utf-8
+ (path-get-extension source-file))))
+ ((|.jpg| |.jpeg|) "image/jpeg")
+ ((|.png|) "image/png")
+ (else 'no-mimetype))
+ 'no-mimetype)))))
+
+ (super-new)))
+
+(define booklet-provider-filesystem%
+ (class booklet-provider%
+ (init-field file)
+
+ (define/override (booklet-file)
+ (and file
+ (build-path (path-only file)
+ "booklet.pdf")))
+
+ (define/override (has-booklet?)
+ (let ((booklet (send this booklet-file)))
+ (and booklet
+ (file-exists? booklet))))
+
+ (super-new)))
diff --git a/library/track-filesystem.rkt b/library/track-filesystem.rkt
new file mode 100644
index 0000000..1f33f34
--- /dev/null
+++ b/library/track-filesystem.rkt
@@ -0,0 +1,116 @@
+#lang racket/base
+
+(require racket-mimetypes/mimetypes
+ racket/class
+ racket/file
+ racket/path
+ "library-ref.rkt"
+ "base/media-resource.rkt"
+ "track-filesystem-providers.rkt"
+ "track-tag-data.rkt"
+ "base/track.rkt"
+ "../misc/utils.rkt")
+
+(provide track-filesystem%)
+
+(define track-filesystem%
+ (class track%
+ (init-field library relative-path)
+
+ (check/c track-filesystem%
+ relative-path
+ list?)
+
+ (define file
+ (send library resolve-path relative-path))
+
+ (define mime-type
+ (mimetype-for-ext
+ file
+ #:default "application/octet-stream"))
+
+ (define tag-source
+ (new tag-source-filesystem%
+ [file file]))
+
+ (super-new
+ [resource
+ (new media-resource-file%
+ [file file]
+ [mime-type mime-type])]
+ [music-library-factory-id
+ (let ((cfg (send library get-cfg)))
+ (library-ref
+ (send cfg get-id)
+ (send cfg get-kind)
+ (send cfg get-kind-version)))]
+ [track-factory-id 'file]
+ [track-relive-info relative-path]
+ [tag-data-provider
+ (new tag-data-provider-filesystem%
+ [tag-source tag-source]
+ [fallback-data
+ (track-tag-data
+ (path->string
+ (file-name-from-path file))
+ ""
+ ""
+ 0
+ 0)])]
+ [image-provider
+ (new image-provider-filesystem%
+ [file file]
+ [tag-source tag-source])]
+ [booklet-provider
+ (new booklet-provider-filesystem%
+ [file file])])))
+
+(module+ test
+ (require rackunit)
+
+ (define file
+ (make-temporary-file "rktplayer-track-~a.mp3"))
+
+ (define cfg%
+ (class object%
+ (define/public (get-id) 'test-library)
+ (define/public (get-kind) 'filesystem)
+ (define/public (get-kind-version) 1)
+ (super-new)))
+
+ (define library%
+ (class object%
+ (define/public (resolve-path relative-path)
+ file)
+ (define/public (get-cfg)
+ (new cfg%))
+ (super-new)))
+
+ (dynamic-wind
+ void
+ (lambda ()
+ (let* ((track
+ (new track-filesystem%
+ [library (new library%)]
+ [relative-path
+ (list (file-name-from-path file))]))
+ (resource (send track get-resource))
+ (library-reference
+ (send track get-music-library-factory-id)))
+ (check-true (is-a? track track%))
+ (check-equal?
+ (send resource get-file)
+ (normal-case-path
+ (path->complete-path file)))
+ (check-equal? (send track get-track-factory-id) 'file)
+ (check-equal? (send track get-track-relive-info)
+ (list (file-name-from-path file)))
+ (check-true (is-a? resource media-resource-file%))
+ (check-true (send resource is-seekable?))
+ (check-equal? (send resource get-mime-type)
+ "audio/mpeg")
+ (check-equal? (library-ref-library-id library-reference)
+ 'test-library)))
+ (lambda ()
+ (when (file-exists? file)
+ (delete-file file)))))
diff --git a/library/track-media-server.rkt b/library/track-media-server.rkt
new file mode 100644
index 0000000..141e748
--- /dev/null
+++ b/library/track-media-server.rkt
@@ -0,0 +1,191 @@
+#lang racket/base
+
+(require net/url
+ racket-mimetypes/mimetypes
+ racket/class
+ racket/list
+ racket/port
+ racket/string
+ (prefix-in upnp: racket-upnp)
+ "base/booklet-provider.rkt"
+ "base/image-provider.rkt"
+ "library-ref.rkt"
+ "base/media-resource.rkt"
+ "base/tag-data-provider.rkt"
+ "track-tag-data.rkt"
+ "base/track.rkt"
+ "../misc/utils.rkt")
+
+(provide track-media-server%)
+
+(define tag-data-provider-media-server%
+ (class tag-data-provider%
+ (init-field
+ entry
+ resource)
+
+ (define/override (get-tag-data)
+ (let ((artists
+ (upnp:media-item-artists entry)))
+ (track-tag-data
+ (upnp:media-entry-title entry)
+ (cond
+ ((not (null? artists))
+ (car artists))
+ ((upnp:media-item-creator entry)
+ (upnp:media-item-creator entry))
+ (else ""))
+ (or (upnp:media-item-album entry)
+ "")
+ (or
+ (upnp:media-item-original-track-number
+ entry)
+ 0)
+ (or (upnp:media-resource-duration
+ resource)
+ 0))))
+
+ (super-new)))
+
+(define image-provider-media-server%
+ (class image-provider%
+ (init-field uri)
+
+ (define mime-type
+ (and uri
+ (mimetype-for-ext
+ (regexp-replace
+ #px"[?#].*$"
+ uri
+ "")
+ #:default
+ "application/octet-stream")))
+
+ (define/private (stored-file target-file)
+ (let ((extension
+ (cond
+ ((equal? mime-type "image/jpeg") ".jpg")
+ ((equal? mime-type "image/png") ".png")
+ (else ""))))
+ (string-append
+ (format "~a" target-file)
+ extension)))
+
+ (define/override (has-image?)
+ (and (string? uri)
+ (not (string=? uri ""))))
+
+ (define/override (image->file target-file)
+ (and
+ (send this has-image?)
+ (with-handlers
+ ((exn:fail?
+ (lambda (exception)
+ (warn-rktplayer
+ "Could not retrieve media-server image: ~a"
+ (exn-message exception))
+ #f)))
+ (let ((file (stored-file target-file)))
+ (call/input-url
+ (string->url uri)
+ get-pure-port
+ (lambda (input)
+ (call-with-output-file
+ file
+ (lambda (output)
+ (copy-port input output))
+ #:exists 'replace)))
+ file))))
+
+ (define/override (image->mimetype)
+ (or mime-type
+ 'no-mimetype))
+
+ (super-new)))
+
+(define booklet-provider-media-server%
+ (class booklet-provider%
+ (define/override (has-booklet?)
+ #f)
+
+ (define/override (booklet-file)
+ #f)
+
+ (super-new)))
+
+(define (audio-resource? resource)
+ (let ((content-type
+ (upnp:media-resource-content-type
+ resource)))
+ (and content-type
+ (string-prefix?
+ content-type
+ "audio/"))))
+
+(define (resource-seekable? resource)
+ (let ((protocol-info
+ (upnp:media-resource-protocol-info
+ resource)))
+ (and protocol-info
+ (regexp-match?
+ #px"DLNA[.]ORG_OP=(?:01|10|11)"
+ protocol-info))))
+
+(define track-media-server%
+ (class track%
+ (init-field
+ library
+ entry)
+
+ (check/c track-media-server%
+ entry
+ upnp:media-item?)
+
+ (define source-resource
+ (or
+ (findf
+ audio-resource?
+ (upnp:media-item-resources entry))
+ (car
+ (upnp:media-item-resources entry))))
+
+ (define resource
+ (new media-resource%
+ [uri
+ (upnp:media-resource-uri
+ source-resource)]
+ [mime-type
+ (upnp:media-resource-content-type
+ source-resource)]
+ [protocol-info
+ (upnp:media-resource-protocol-info
+ source-resource)]
+ [seekable?
+ (resource-seekable?
+ source-resource)]))
+
+ (super-new
+ [resource resource]
+ [music-library-factory-id
+ (let ((cfg (send library get-cfg)))
+ (library-ref
+ (send cfg get-id)
+ (send cfg get-kind)
+ (send cfg get-kind-version)))]
+ [track-factory-id
+ 'media-server-item]
+ [track-relive-info
+ (list
+ (upnp:media-entry-parent-id entry)
+ (upnp:media-entry-id entry))]
+ [tag-data-provider
+ (new tag-data-provider-media-server%
+ [entry entry]
+ [resource source-resource])]
+ [image-provider
+ (new image-provider-media-server%
+ [uri
+ (upnp:media-item-album-art-uri
+ entry)])]
+ [booklet-provider
+ (new booklet-provider-media-server%)])))
diff --git a/library/track-store.rkt b/library/track-store.rkt
new file mode 100644
index 0000000..3277b9b
--- /dev/null
+++ b/library/track-store.rkt
@@ -0,0 +1,175 @@
+#lang racket/base
+
+(require racket/class
+ racket/match
+ "library-factory.rkt"
+ "library-ref.rkt"
+ "base/track.rkt"
+ "../misc/utils.rkt")
+
+(provide track-store?
+ track-store-id
+ track-store-number
+ track-store-title
+ track->store
+ store->track)
+
+(define track-store-version
+ 1)
+
+(define (track-store? stored)
+ (match stored
+ ((list 'track
+ (== track-store-version)
+ _
+ number
+ title
+ library-reference
+ track-factory-id
+ _)
+ (and (exact-integer? number)
+ (string? title)
+ (library-ref? library-reference)
+ (symbol? track-factory-id)))
+ (else #f)))
+
+(define (track-store-id stored)
+ (check/c track-store-id stored track-store?)
+ (list-ref stored 2))
+
+(define (track-store-number stored)
+ (check/c track-store-number stored track-store?)
+ (list-ref stored 3))
+
+(define (track-store-title stored)
+ (check/c track-store-title stored track-store?)
+ (list-ref stored 4))
+
+(define (track->store track)
+ (check/c track->store track (is-a?/c track<%>))
+
+ (let ((stored
+ (list 'track
+ track-store-version
+ (send track get-id)
+ (send track get-number)
+ (send track get-title)
+ (send track get-music-library-factory-id)
+ (send track get-track-factory-id)
+ (send track get-track-relive-info))))
+ (check/c track->store stored track-store?)
+ stored))
+
+(define (store->track stored factory)
+ (check/c store->track
+ factory
+ (is-a?/c library-factory%))
+
+ (and
+ (track-store? stored)
+ (with-handlers ((exn:fail?
+ (lambda (_)
+ #f)))
+ (let* ((library-reference (list-ref stored 5))
+ (library
+ (send factory
+ get-library
+ (library-ref-library-id library-reference)
+ (library-ref-kind library-reference)
+ (library-ref-version library-reference)))
+ (root-container
+ (send library get-root-container))
+ (track-reliver
+ (send root-container get-track-reliver))
+ (track
+ (track-reliver
+ (list-ref stored 6)
+ (list-ref stored 7))))
+ (and (object? track)
+ (is-a? track track<%>)
+ track)))))
+
+(module+ test
+ (require rackunit
+ racket/file
+ "libraries-config.rkt"
+ "library-filesystem.rkt"
+ "library-item.rkt")
+
+ (define settings%
+ (class object%
+ (define values
+ (make-hash))
+
+ (define/public (clone _)
+ this)
+
+ (define/public (get key default)
+ (hash-ref values key default))
+
+ (define/public (set! key value)
+ (hash-set! values key value))
+
+ (super-new)))
+
+ (define root
+ (make-temporary-file
+ "rktplayer-track-store-~a"
+ 'directory))
+
+ (define file-name
+ "track.mp3")
+
+ (define file
+ (build-path root file-name))
+
+ (dynamic-wind
+ (lambda ()
+ (call-with-output-file file void))
+ (lambda ()
+ (let* ((libraries-config
+ (new libraries-config%
+ [settings (new settings%)]))
+ (factory
+ (new library-factory%
+ [libraries-config libraries-config])))
+ (send libraries-config
+ add-library
+ (library-item
+ 'test-library
+ "Test library"
+ 'filesystem
+ 1
+ root
+ #f
+ 100
+ #t))
+ (register-library-filesystem! factory)
+
+ (let* ((library
+ (send factory
+ get-library
+ 'test-library
+ 'filesystem
+ 1))
+ (track
+ (send library
+ make-track
+ (list (string->path file-name))))
+ (stored (track->store track))
+ (relived (store->track stored factory)))
+ (check-true (track-store? stored))
+ (check-equal? (track-store-id stored)
+ (send track get-id))
+ (check-equal? (track-store-number stored)
+ (send track get-number))
+ (check-equal? (track-store-title stored)
+ (send track get-title))
+ (check-true (is-a? relived track<%>))
+ (check-equal?
+ (normal-case-path
+ (send (send relived get-resource)
+ get-file))
+ (normal-case-path file)))))
+ (lambda ()
+ (delete-directory/files root))))
diff --git a/library/track-tag-data.rkt b/library/track-tag-data.rkt
new file mode 100644
index 0000000..c6c74a7
--- /dev/null
+++ b/library/track-tag-data.rkt
@@ -0,0 +1,7 @@
+#lang racket/base
+
+(provide (struct-out track-tag-data))
+
+(struct track-tag-data
+ (title artist album number length)
+ #:prefab)
diff --git a/utils.rkt b/misc/utils.rkt
similarity index 67%
rename from utils.rkt
rename to misc/utils.rkt
index 16f8b80..e239d7a 100644
--- a/utils.rkt
+++ b/misc/utils.rkt
@@ -1,6 +1,7 @@
#lang racket/base
(require racket/gui
+ racket/contract
xml
xml/xexpr
simple-log
@@ -12,7 +13,6 @@
simple-row-formatter
while
open-file-manager
- basedir
dbg-rktplayer
err-rktplayer
info-rktplayer
@@ -24,11 +24,59 @@
path-equal?
make-select-list
new-id
+ check/c
+ check/c*
+ (all-from-out racket/contract)
)
(sl-def-log rktplayer)
+(define-syntax check/c
+ (syntax-rules ()
+ ((_ for-cl for-func name contract-expr)
+ (unless (contract-first-order-passes? contract-expr name)
+ (raise-argument-error
+ (string->symbol (format "~a:~a" 'for-cl 'for-func))
+ (format "~s" 'contract-expr)
+ name)))
+ ((_ for-cl name contract-expr)
+ (unless (contract-first-order-passes? contract-expr name)
+ (raise-argument-error
+ 'for-cl
+ (format "~s" 'contract-expr)
+ name)))
+ ((_ name contract-expr)
+ (unless (contract-first-order-passes? contract-expr name)
+ (error
+ (format "~a: expected ~a, got ~a"
+ 'name
+ 'contract-expr
+ name))))))
+
+(define-syntax check/c*-internal
+ (syntax-rules ()
+ ((_ for-cl (for-func name type?))
+ (check/c for-cl for-func name type?))
+ ((_ for-cl (name type?))
+ (check/c for-cl name type?))))
+
+(define-syntax check/c*-internal-func
+ (syntax-rules ()
+ ((_ for-cl for-func (name type?))
+ (check/c for-cl for-func name type?))))
+
+(define-syntax check/c*
+ (syntax-rules ()
+ ((_ (for-cl for-func) check ...)
+ (begin
+ (check/c*-internal-func for-cl for-func check)
+ ...))
+ ((_ for-cl check ...)
+ (begin
+ (check/c*-internal for-cl check)
+ ...))))
+
(define-syntax while
(syntax-rules ()
((_ cond body ...)
@@ -114,15 +162,6 @@
[else (do-open "xdg-open" folder)]))
)
-(define (basedir file)
- (if (string? file)
- (basedir (string->path file))
- (if (or (eq? (file-or-directory-type file) 'file)
- (eq? (file-or-directory-type file) 'link))
- (call-with-values (λ () (split-path file))
- (λ (dir file d) dir))
- file)))
-
(define (path-equal? p1 p2)
(let ((p1* (build-path p1))
(p2* (build-path p2))
@@ -169,4 +208,41 @@
(id (string->symbol (format "id-~a-~a" s r))))
id))
-
\ No newline at end of file
+(module+ test
+ (require rackunit)
+
+ (define (multiply a b c)
+ (check/c* (my-class multiply)
+ (a number?)
+ (b number?)
+ (c symbol?))
+ (format "symbol ~a = ~a" c (* a b)))
+
+ (check-equal? (multiply 2 3 'answer)
+ "symbol answer = 6")
+
+ (check-not-exn
+ (lambda ()
+ (define value 1)
+ (check/c my-class value number?)))
+
+ (check-exn
+ exn:fail:contract?
+ (lambda ()
+ (multiply 2 "3" 'answer)))
+
+ (check-exn
+ #rx"my-class:multiply"
+ (lambda ()
+ (multiply 2 3 "answer")))
+
+ (check-not-exn
+ (lambda ()
+ (define value "root")
+ (check/c value (or/c path? string?))))
+
+ (check-exn
+ #rx"or/c"
+ (lambda ()
+ (define value 42)
+ (check/c my-class value (or/c path? string?)))))
diff --git a/music-library.rkt b/music-library.rkt
deleted file mode 100644
index 03af7b5..0000000
--- a/music-library.rkt
+++ /dev/null
@@ -1,53 +0,0 @@
-#lang racket
-
-(require racket-audio)
-
-(provide music-lib-relevant?
- is-music-dir?
- is-music-file?
- basename
- library-formatter
- )
-
-(define (music-lib-relevant? f)
- (let ((type (file-or-directory-type f #t)))
- (if (eq? type 'directory)
- (let ((name (basename f)))
- (not (string-prefix? name ".")))
- (if (eq? type 'file)
- (let* ((fn (string-downcase (format "~a" f)))
- (exts (audio-known-exts?)))
- (let ((l (filter (λ (e) (string-suffix? fn (string-append "." e))) exts)))
- (not (null? l))))
- #f))))
-
-(define (is-music-dir? f)
- (and (music-lib-relevant? f)
- (directory-exists? f)))
-
-(define (is-music-file? f)
- (and (music-lib-relevant? f)
- (file-exists? f)))
-
-(define (basename file)
- (call-with-values (λ () (split-path file))
- (λ (base name is-dir)
- (path->string name))))
-
-(define (library-formatter row)
- (let* ((file-entry (car row))
- (file-id (format "file-~a" (cadr row)))
- (the-file (string-replace
- (if (equal? file-id "lib-up") ".." (format "~a" file-entry))
- "\\" "/"))
- )
- ;(displayln row)
- (list (list 'td (list (list 'class "library-entry") (list 'id file-id) (list 'file (format "~a" the-file)))
- (if (equal? file-id "lib-up")
- file-entry
- (basename file-entry))
- ))
- )
- )
-
-
diff --git a/player.rkt b/play/base/player.rkt
similarity index 74%
rename from player.rkt
rename to play/base/player.rkt
index e129f14..429ae5f 100644
--- a/player.rkt
+++ b/play/base/player.rkt
@@ -2,7 +2,8 @@
(require racket/class
racket-audio
- "utils.rkt"
+ "../../misc/utils.rkt"
+ "../../library/base/media-resource.rkt"
lru-cache
)
@@ -114,11 +115,23 @@
(define/public (get-volume)
(check-player)
- (audio-volume player))
+ (* 100.0
+ (sqrt
+ (/ (min 100.0
+ (max 0.0
+ (audio-volume player)))
+ 100.0))))
(define/public (set-volume! percentage)
(check-player)
- (audio-volume! player percentage))
+ (let ((value
+ (/ (min 100.0
+ (max 0.0 percentage))
+ 100.0)))
+ (audio-volume! player
+ (* 100.0
+ value
+ value))))
(define/public (set-list! playlist*)
;; if the player exists and is playing, stop it.
@@ -138,14 +151,25 @@
(define/public (play playlist*)
(send this playlist! playlist*)
- (send this play-track 0))
+ (let ((track-nr
+ (send playlist
+ first-available-track-index)))
+ (when track-nr
+ (send this play-track track-nr))))
(define/public (play-track nr)
(check-player)
(when (and (>= nr 0) (< nr (send playlist length)))
(let ((track (send playlist track nr)))
- (let ((id (audio-play! player (send track get-file))))
- (register-music-id&track-nr id nr)))))
+ (when track
+ (let ((file
+ (send playlist track-file nr)))
+ (if file
+ (let ((id (audio-play! player file)))
+ (register-music-id&track-nr id nr))
+ (warn-rktplayer
+ "Track is not locally available: ~a"
+ (send track get-title))))))))
(define/public (next)
(check-player)
@@ -154,21 +178,18 @@
(let ((track-nr (music-id->track-nr music-id)))
(if (eq? track-nr #f)
(error "Unexpected: no track-nr for given music-id")
- (begin
- (cond
- ((eq? repeat 'repeat-one) (play-track track-nr))
- ((eq? repeat 'repeat-all)
- (set! track-nr (+ track-nr 1))
- (when (>= track-nr (send playlist length))
- (set! track-nr 0))
- (play-track track-nr))
- (else
- (set! track-nr (+ track-nr 1))
- (if (>= track-nr (send playlist length))
- (stop)
- (play-track track-nr)))
- )
- )
+ (if (eq? repeat 'repeat-one)
+ (send this play-track track-nr)
+ (let ((next-track-nr
+ (send playlist
+ next-available-track-index
+ track-nr
+ (eq? repeat 'repeat-all))))
+ (if next-track-nr
+ (send this
+ play-track
+ next-track-nr)
+ (send this stop))))
)
)
)
@@ -181,20 +202,17 @@
(let ((track-nr (music-id->track-nr music-id)))
(if (eq? track-nr #f)
(error "Unexpected: no track-nr for given music-id")
- (begin
- (cond
- ((eq? repeat 'repeat-one) (play-track track-nr))
- ((eq? repeat 'repeat-all)
- (set! track-nr (- track-nr 1))
- (when (< track-nr 0)
- (set! track-nr (- (send playlist length) 1)))
- (play-track track-nr))
- (else
- (set! track-nr (- track-nr 1))
- (when (< track-nr 0) (set! track-nr 0))
- (play-track track-nr))
- )
- )
+ (if (eq? repeat 'repeat-one)
+ (send this play-track track-nr)
+ (let ((previous-track-nr
+ (send playlist
+ previous-available-track-index
+ track-nr
+ (eq? repeat 'repeat-all))))
+ (send this
+ play-track
+ (or previous-track-nr
+ track-nr))))
)
)
)
@@ -215,8 +233,8 @@
(send this play!)))
(define/public (stop)
- (check-player)
- (audio-stop! player))
+ (unless (eq? player #f)
+ (audio-stop! player)))
(define/public (seek percentage)
(check-player)
diff --git a/play/base/renderer.rkt b/play/base/renderer.rkt
new file mode 100644
index 0000000..9acf965
--- /dev/null
+++ b/play/base/renderer.rkt
@@ -0,0 +1,163 @@
+#lang racket/base
+
+(require racket/class
+ racket/list
+ "../../misc/utils.rkt")
+
+(provide renderer%
+ renderer-preferences%)
+
+(define renderer-preferences%
+ (class object%
+ (init-field settings)
+
+ (define cfg
+ (send settings clone 'renderers))
+
+ (define/private (stored)
+ (send cfg get
+ 'volume-curves
+ '()))
+
+ (define/public (get-volume-curve id)
+ (let ((entry
+ (assoc id
+ (stored)
+ equal?)))
+ (if entry
+ (cadr entry)
+ 'linear)))
+
+ (define/public (set-volume-curve! id curve)
+ (check/c renderer-preferences%
+ set-volume-curve!
+ curve
+ (or/c 'linear
+ 'logarithmic))
+ (let ((without-id
+ (filter
+ (lambda (entry)
+ (not
+ (equal? (car entry)
+ id)))
+ (stored))))
+ (send cfg
+ set!
+ 'volume-curves
+ (cons (list id curve)
+ without-id))))
+
+ (super-new)))
+
+(module+ test
+ (require rackunit)
+
+ (define values (make-hash))
+ (define test-settings%
+ (class object%
+ (define/public (clone name)
+ (void name)
+ this)
+ (define/public (get name default)
+ (hash-ref values name default))
+ (define/public (set! name value)
+ (hash-set! values name value))
+ (super-new)))
+
+ (define preferences
+ (new renderer-preferences%
+ [settings (new test-settings%)]))
+ (define renderer
+ (new renderer%
+ [id "renderer-id"]
+ [name "Renderer"]
+ [kind 'test]
+ [device 'device]
+ [preferences preferences]))
+
+ (check-= (send renderer
+ logical-volume->device
+ 25)
+ 25
+ 0.001)
+ (send renderer
+ set-volume-curve!
+ 'logarithmic)
+ (check-eq? (send renderer get-volume-curve)
+ 'logarithmic)
+ (check-= (send renderer
+ logical-volume->device
+ 50)
+ 25
+ 0.001)
+ (check-= (send renderer
+ device-volume->logical
+ 25)
+ 50
+ 0.001))
+
+(define renderer%
+ (class object%
+ (init-field
+ id
+ name
+ kind
+ device
+ preferences)
+
+ (check/c* renderer%
+ (id string?)
+ (name string?)
+ (kind symbol?)
+ (preferences
+ (is-a?/c renderer-preferences%)))
+
+ (define/public (get-id)
+ id)
+
+ (define/public (get-name)
+ name)
+
+ (define/public (get-kind)
+ kind)
+
+ (define/public (get-device)
+ device)
+
+ (define/public (get-volume-curve)
+ (send preferences
+ get-volume-curve
+ id))
+
+ (define/public (set-volume-curve! curve)
+ (send preferences
+ set-volume-curve!
+ id
+ curve))
+
+ (define/private (clamp percentage)
+ (min 100.0
+ (max 0.0
+ percentage)))
+
+ (define/public (logical-volume->device percentage)
+ (let ((value
+ (/ (clamp percentage)
+ 100.0)))
+ (* 100.0
+ (case (send this get-volume-curve)
+ ((logarithmic)
+ (* value value))
+ (else value)))))
+
+ (define/public (device-volume->logical percentage)
+ (let ((value
+ (/ (clamp percentage)
+ 100.0)))
+ (* 100.0
+ (case (send this get-volume-curve)
+ ((logarithmic)
+ (sqrt value))
+ (else value)))))
+
+ (super-new)))
diff --git a/play/dlna-player.rkt b/play/dlna-player.rkt
new file mode 100644
index 0000000..4da6bcc
--- /dev/null
+++ b/play/dlna-player.rkt
@@ -0,0 +1,588 @@
+#lang racket
+
+(require racket/class
+ racket/path
+ (prefix-in rad: racket-audio-dlna)
+ "../library/base/media-resource.rkt"
+ "base/renderer.rkt"
+ "../misc/utils.rkt")
+
+(provide dlna-player%)
+
+(define dlna-player%
+ (class object%
+ (init-field [renderer #f]
+ [settings #f]
+ [time-updater (lambda (time-s length-s) #t)]
+ [track-nr-updater (lambda (nr) #t)]
+ [state-updater (lambda (state) #t)]
+ [error-updater
+ (lambda (kind detail) #t)]
+ [repeat-updater (lambda (state) #t)]
+ [audio-info-cb (lambda (rate channels bits kind) #t)]
+ [buffer-max-seconds 10]
+ [buffer-min-seconds 4]
+ [server-url #f]
+ [server-port 8734] ;8080]
+ [listen-ip #f]
+ [poll-seconds 1.0]
+ [volume-poll-seconds 5.0])
+
+ (define player #f)
+ (define playlist #f)
+ (define state 'stopped)
+ (define repeat 'no-repeat)
+ (define current-track-nr #f)
+ (define current-uri #f)
+ (define prepared-next-track-nr #f)
+ (define playing-seen? #f)
+ (define playback-progress-seen? #f)
+ (define playback-failure-active? #f)
+ (define play-request-ms #f)
+ (define stop-requested? #f)
+ (define stopped-polls 0)
+ (define renderer-reachable? #t)
+ (define playback-start-timeout-ms 8000)
+ (define running #t)
+ (define poll-thread #f)
+
+ (define (now-ms)
+ (current-inexact-milliseconds))
+
+ (define (track-title nr)
+ (let ((track
+ (and playlist
+ (exact-nonnegative-integer? nr)
+ (send playlist track nr))))
+ (if track
+ (send track get-title)
+ "")))
+
+ (define (report-playback-failure! detail)
+ (set! playing-seen? #f)
+ (set! playback-progress-seen? #f)
+ (set! playback-failure-active? #t)
+ (set! play-request-ms #f)
+ (set! stopped-polls 0)
+ (error-updater 'playback-failed detail))
+
+ (define (renderer-command! name command)
+ (with-handlers
+ ((exn:fail?
+ (lambda (e)
+ (warn-rktplayer
+ "Could not execute DLNA command ~a: ~a"
+ name
+ (exn-message e))
+ (error-updater
+ 'renderer-command-failed
+ (send renderer get-name))
+ #f)))
+ (command)
+ #t))
+
+ (define (check-player)
+ (unless (is-a? renderer renderer%)
+ (raise-arguments-error
+ 'dlna-player%
+ "no media renderer has been configured"
+ "renderer" renderer))
+ (when (eq? player #f)
+ (unless (eq? server-url #f)
+ (warn-rktplayer
+ "server-url is ignored; racket-audio-dlna determines the server URL"))
+ (set! player
+ (rad:make-dlna-player
+ (send renderer get-device)
+ #:listen-ip listen-ip
+ #:port server-port
+ #:path "/rktplayer/"
+ #:poll-seconds poll-seconds
+ #:volume-poll-seconds volume-poll-seconds))))
+
+ (define (normalize-state st)
+ (cond
+ [(eq? st 'playing) 'playing]
+ [(eq? st 'transitioning) 'starting]
+ [(eq? st 'paused) 'paused]
+ [(or (eq? st 'stopped)
+ (eq? st 'no-media))
+ 'stopped]
+ [else st]))
+
+ (define (set-state! st)
+ (unless (eq? state st)
+ (set! state st)
+ (state-updater state))
+ (repeat-updater repeat)
+ (when (or (eq? state 'stopped)
+ (eq? state 'quit))
+ (audio-info-cb 0 0 0 'none)))
+
+ (define (file-format file)
+ (let* ((value
+ (cond
+ ((path? file) (path->string file))
+ ((string? file) file)
+ (else #f)))
+ (match
+ (and value
+ (regexp-match
+ #px"(?i:[.]([a-z0-9]+)(?:[?#].*)?$)"
+ value))))
+ (if match
+ (string->symbol (string-downcase (cadr match)))
+ 'none)))
+
+ (define (track-audio-info! track)
+ (if track
+ (audio-info-cb
+ (or (rad:dlna-track-info-sample-rate track) 0)
+ (or (rad:dlna-track-info-channels track) 0)
+ 0
+ (file-format (rad:dlna-track-info-file track)))
+ (audio-info-cb 0 0 0 'none)))
+
+ (define (normalized-file file)
+ (with-handlers ([exn:fail? (lambda (_) (format "~a" file))])
+ (path->string (path->complete-path file))))
+
+ (define (same-file? file1 file2)
+ (and file1
+ file2
+ ((if (eq? (system-type 'os) 'windows)
+ string-ci=?
+ string=?)
+ (normalized-file file1)
+ (normalized-file file2))))
+
+ (define (playlist-track-file nr)
+ (let* ((track (send playlist track nr))
+ (resource
+ (and track
+ (send track get-resource))))
+ (and resource
+ (is-a? resource media-resource%)
+ (send resource get-file))))
+
+ (define (playlist-track-uri nr)
+ (let ((track (send playlist track nr)))
+ (and track
+ (send (send track get-resource)
+ get-uri))))
+
+ (define (playlist-track-info nr)
+ (let* ((track (send playlist track nr))
+ (resource (send track get-resource)))
+ (rad:dlna-track-info
+ (or (send resource get-file)
+ (send resource get-uri))
+ (send track get-title)
+ (send track get-artist)
+ (send track get-album)
+ #f
+ #f
+ (send track get-number)
+ (send track get-length)
+ #f
+ #f
+ #f)))
+
+ (define (playlist-track-mime-type nr)
+ (send (send (send playlist track nr)
+ get-resource)
+ get-mime-type))
+
+ (define (playlist-track-protocol-info nr)
+ (send (send (send playlist track nr)
+ get-resource)
+ get-protocol-info))
+
+ (define (playlist-track-nr file uri)
+ (and playlist
+ (for/first ([nr (in-range (send playlist length))]
+ #:when
+ (or (same-file?
+ file
+ (playlist-track-file nr))
+ (and (string? uri)
+ (equal?
+ uri
+ (playlist-track-uri nr)))))
+ nr)))
+
+ (define (next-track-nr nr)
+ (if (eq? repeat 'repeat-one)
+ nr
+ (send playlist
+ next-valid-track-index
+ nr
+ (eq? repeat 'repeat-all))))
+
+ (define (prepare-next-track!)
+ (when (and player
+ playlist
+ (exact-nonnegative-integer? current-track-nr))
+ (let ((nr (next-track-nr current-track-nr)))
+ (cond
+ [(eq? nr #f)
+ (set! prepared-next-track-nr #f)]
+ [(not (equal? nr prepared-next-track-nr))
+ (let ((file (playlist-track-file nr)))
+ (with-handlers
+ ([exn:fail?
+ (lambda (e)
+ (set! prepared-next-track-nr #f)
+ (warn-rktplayer
+ "Could not prepare next DLNA track: ~a"
+ (exn-message e)))])
+ (if file
+ (rad:dlna-player-set-next-file!
+ player
+ file)
+ (rad:dlna-player-set-next-uri!
+ player
+ (playlist-track-uri nr)
+ #:mime-type
+ (playlist-track-mime-type nr)
+ #:protocol-info
+ (playlist-track-protocol-info nr)
+ #:track
+ (playlist-track-info nr)))
+ (set! prepared-next-track-nr nr)))]))))
+
+ (define (update-current-track! info)
+ (let* ((track (rad:dlna-info-track info))
+ (file (and track (rad:dlna-track-info-file track)))
+ (uri (rad:dlna-info-uri info))
+ (nr (cond
+ [(and (exact-nonnegative-integer?
+ prepared-next-track-nr)
+ (or
+ (same-file?
+ file
+ (playlist-track-file
+ prepared-next-track-nr))
+ (and (string? uri)
+ (equal?
+ uri
+ (playlist-track-uri
+ prepared-next-track-nr)))))
+ prepared-next-track-nr]
+ [else
+ (playlist-track-nr file uri)])))
+ (when (exact-nonnegative-integer? nr)
+ (unless (equal? nr current-track-nr)
+ (set! playback-progress-seen? #f)
+ (set! play-request-ms (now-ms)))
+ (set! current-track-nr nr)
+ (set! prepared-next-track-nr #f)
+ (track-nr-updater nr)
+ (track-audio-info! track)
+ (prepare-next-track!))))
+
+ (define (poll-renderer)
+ (when player
+ (let ((info (rad:dlna-player-info player)))
+ (if (not (rad:dlna-info-reachable? info))
+ (when renderer-reachable?
+ (set! renderer-reachable? #f)
+ (warn-rktplayer "DLNA renderer is not reachable")
+ (error-updater
+ 'renderer-unreachable
+ (send renderer get-name)))
+ (let* ((new-state
+ (normalize-state (rad:dlna-info-state info)))
+ (uri (rad:dlna-info-uri info))
+ (position (rad:dlna-info-position info))
+ (duration (rad:dlna-info-duration info))
+ (playback-failed? #f))
+ (unless renderer-reachable?
+ (dbg-rktplayer "DLNA renderer is reachable again"))
+ (set! renderer-reachable? #t)
+
+ (when (and (string? uri)
+ (not (string=? uri ""))
+ (not (equal? uri current-uri)))
+ (set! current-uri uri)
+ (set! stopped-polls 0)
+ (update-current-track! info))
+
+ (when (or (eq? new-state 'playing)
+ (eq? new-state 'starting)
+ (eq? new-state 'paused))
+ (when (and (number? position)
+ (> position 0))
+ (set! playback-progress-seen? #t))
+ (when (and (number? position)
+ (number? duration))
+ (time-updater position duration))
+ (track-audio-info! (rad:dlna-info-track info)))
+
+ (when (and playing-seen?
+ (not playback-progress-seen?)
+ play-request-ms
+ (>= (- (now-ms)
+ play-request-ms)
+ playback-start-timeout-ms))
+ (set! playback-failed? #t)
+ (report-playback-failure!
+ (track-title current-track-nr)))
+
+ (unless (or playback-failed?
+ playback-failure-active?)
+ (cond
+ [(eq? new-state 'playing)
+ (set! playing-seen? #t)
+ (set! stopped-polls 0)]
+ [(and (eq? new-state 'stopped)
+ stop-requested?)
+ (set! stop-requested? #f)
+ (set! stopped-polls 0)]
+ [(and (eq? new-state 'stopped)
+ playing-seen?)
+ (cond
+ ((and
+ (not playback-progress-seen?)
+ play-request-ms
+ (< (- (now-ms)
+ play-request-ms)
+ 5000))
+ (void))
+ ((not playback-progress-seen?)
+ (report-playback-failure!
+ (track-title current-track-nr)))
+ (else
+ (set! stopped-polls
+ (+ stopped-polls 1))
+ ;; Give SetNextAVTransportURI one poll to take over.
+ (when (or
+ (eq? prepared-next-track-nr #f)
+ (> stopped-polls 1))
+ (set! playing-seen? #f)
+ (set! stopped-polls 0)
+ (send this next))))]))
+
+ (set-state!
+ (cond
+ ((or playback-failed?
+ playback-failure-active?)
+ 'stopped)
+ ((and playing-seen?
+ (not playback-progress-seen?))
+ 'starting)
+ (else new-state))))))))
+
+ (define (poll)
+ (let loop ()
+ (when running
+ (sleep poll-seconds)
+ (when running
+ (with-handlers
+ ([exn:fail?
+ (lambda (e)
+ (warn-rktplayer
+ "Could not update DLNA player state: ~a"
+ (exn-message e)))])
+ (poll-renderer))
+ (loop)))))
+
+ (define/public (change-player kind
+ #:host [host #f]
+ #:basepaths [basepaths #f])
+ (void kind host basepaths)
+ (warn-rktplayer
+ "change-player is not supported by dlna-player%"))
+
+ (define/public (get-volume)
+ (check-player)
+ (send renderer
+ device-volume->logical
+ (or (rad:dlna-info-volume
+ (rad:dlna-player-info player))
+ 0)))
+
+ (define/public (set-volume! percentage)
+ (check-player)
+ (renderer-command!
+ 'volume
+ (lambda ()
+ (rad:dlna-player-volume!
+ player
+ (send renderer
+ logical-volume->device
+ percentage)))))
+
+ (define/public (set-list! playlist*)
+ (when player
+ (with-handlers ([exn:fail? (lambda (_) (void))])
+ (rad:dlna-player-stop! player)))
+ (set! playlist playlist*)
+ (set! current-track-nr #f)
+ (set! current-uri #f)
+ (set! prepared-next-track-nr #f)
+ (set! playing-seen? #f)
+ (set! playback-progress-seen? #f)
+ (set! playback-failure-active? #f)
+ (set! play-request-ms #f)
+ (set! stop-requested? #f)
+ (set! stopped-polls 0)
+ (set-state! 'stopped))
+
+ (define/public (playlist! playlist*)
+ (check-player)
+ (set-list! playlist*))
+
+ (define/public (play playlist*)
+ (send this playlist! playlist*)
+ (let ((track-nr
+ (send playlist
+ first-valid-track-index)))
+ (when track-nr
+ (send this play-track track-nr))))
+
+ (define/public (play-track nr)
+ (check-player)
+ (when (and playlist
+ (>= nr 0)
+ (< nr (send playlist length)))
+ (with-handlers
+ ((exn:fail?
+ (lambda (e)
+ (warn-rktplayer
+ "Could not play DLNA track: ~a"
+ (exn-message e))
+ (report-playback-failure!
+ (track-title nr))
+ (set-state! 'stopped))))
+ (let ((file (playlist-track-file nr)))
+ (if file
+ (rad:dlna-player-play! player file)
+ (rad:dlna-player-play-uri!
+ player
+ (playlist-track-uri nr)
+ #:mime-type
+ (playlist-track-mime-type nr)
+ #:protocol-info
+ (playlist-track-protocol-info nr)
+ #:track
+ (playlist-track-info nr)))
+ (when (or file
+ (playlist-track-uri nr))
+ (let ((info (rad:dlna-player-info player)))
+ (set! current-track-nr nr)
+ (set! current-uri (rad:dlna-info-uri info))
+ (set! prepared-next-track-nr #f)
+ (set! playing-seen? #t)
+ (set! playback-progress-seen? #f)
+ (set! playback-failure-active? #f)
+ (set! play-request-ms (now-ms))
+ (set! stop-requested? #f)
+ (set! stopped-polls 0)
+ (track-nr-updater nr)
+ (track-audio-info! (rad:dlna-info-track info))
+ (set-state! 'starting)
+ (prepare-next-track!)))))))
+
+ (define/public (next)
+ (check-player)
+ (if (eq? current-track-nr #f)
+ (warn-rktplayer
+ "No track-nr set (yet), so can't play anything next")
+ (let ((nr (next-track-nr current-track-nr)))
+ (if (eq? nr #f)
+ (send this stop)
+ (send this play-track nr)))))
+
+ (define/public (previous)
+ (check-player)
+ (if (eq? current-track-nr #f)
+ (warn-rktplayer
+ "No track-nr set (yet), so can't play anything previous")
+ (let ((nr current-track-nr))
+ (if (eq? repeat 'repeat-one)
+ (send this play-track nr)
+ (let ((previous-track-nr
+ (send playlist
+ previous-valid-track-index
+ nr
+ (eq? repeat 'repeat-all))))
+ (send this
+ play-track
+ (or previous-track-nr
+ nr)))))))
+
+ (define/public (pause!)
+ (check-player)
+ (when (renderer-command!
+ 'pause
+ (lambda ()
+ (rad:dlna-player-pause! player)))
+ (set-state! 'paused)))
+
+ (define/public (play!)
+ (check-player)
+ (when (renderer-command!
+ 'play
+ (lambda ()
+ (rad:dlna-player-resume! player)))
+ (set-state! 'playing)))
+
+ (define/public (pause-unpause)
+ (check-player)
+ (if (eq? state 'paused)
+ (send this play!)
+ (send this pause!)))
+
+ (define/public (stop)
+ (set! stop-requested? #t)
+ (set! playing-seen? #f)
+ (set! playback-progress-seen? #f)
+ (set! playback-failure-active? #f)
+ (set! play-request-ms #f)
+ (set! stopped-polls 0)
+ (unless (eq? player #f)
+ (renderer-command!
+ 'stop
+ (lambda ()
+ (rad:dlna-player-stop! player))))
+ (set-state! 'stopped))
+
+ (define/public (seek percentage)
+ (check-player)
+ (renderer-command!
+ 'seek
+ (lambda ()
+ (rad:dlna-player-seek-percentage!
+ player
+ percentage))))
+
+ (define/public (get-repeat)
+ (check-player)
+ repeat)
+
+ (define/public (repeat! r)
+ (check-player)
+ (set! repeat r)
+ (repeat-updater repeat)
+ (prepare-next-track!))
+
+ (define/public (quit)
+ (when running
+ (set! running #f)
+ (unless (eq? poll-thread #f)
+ (kill-thread poll-thread)
+ (set! poll-thread #f))
+ (unless (eq? player #f)
+ (rad:dlna-player-close! player)
+ (set! player #f))
+ (set-state! 'quit)))
+
+ (super-new)
+
+ (begin
+ (void settings
+ buffer-max-seconds
+ buffer-min-seconds)
+ (set! poll-thread (thread poll))
+ (dbg-rktplayer "dlna-player% initialized"))))
diff --git a/play/dlna.rkt b/play/dlna.rkt
new file mode 100644
index 0000000..97c06ad
--- /dev/null
+++ b/play/dlna.rkt
@@ -0,0 +1,113 @@
+#lang racket
+
+(require racket/class
+ racket/list
+ racket-sonos
+ racket-upnp
+ "renderer-sonos.rkt"
+ "renderer-upnp.rkt"
+ "../misc/utils.rkt")
+
+(provide check-dlna-players)
+
+(define running-sem (make-semaphore 1))
+(define running #f)
+
+(define (normalized-device-id device)
+ (let ((id (upnp-device-udn device)))
+ (and id
+ (let ((match
+ (regexp-match
+ #px"(?i:RINCON_[0-9A-F]+)"
+ id)))
+ (if match
+ (string-upcase
+ (car match))
+ (regexp-replace
+ #px"(?i:^uuid:)"
+ id
+ ""))))))
+
+(define (represented-by-sonos-group? device member-ids)
+ (let ((id (normalized-device-id device)))
+ (and id
+ (ormap
+ (lambda (member-id)
+ (string-ci=? id member-id))
+ member-ids))))
+
+(define (make-generic-renderers devices preferences
+ #:excluded-ids [excluded-ids '()])
+ (for/list ((device
+ (in-list
+ (filter media-renderer? devices)))
+ #:unless
+ (represented-by-sonos-group?
+ device
+ excluded-ids))
+ (new renderer-upnp%
+ [upnp-device device]
+ [name
+ (if (sonos-device? device)
+ (sonos-device-name device)
+ #f)]
+ [preferences preferences])))
+
+(define (discover-renderers preferences)
+ (let* ((devices (query-upnp-devices 'all))
+ (groups
+ (with-handlers
+ ((exn:fail?
+ (lambda (e)
+ (warn-rktplayer
+ "Could not read Sonos topology; using generic UPnP renderers: ~a"
+ (exn-message e))
+ '())))
+ (sonos-groups devices)))
+ (renderers
+ (if (null? groups)
+ (make-generic-renderers
+ devices
+ preferences)
+ (append
+ (make-generic-renderers
+ devices
+ preferences
+ #:excluded-ids
+ (append-map
+ sonos-group-member-ids
+ groups))
+ (for/list ((group (in-list groups)))
+ (new renderer-sonos%
+ [sonos-group group]
+ [preferences preferences]))))))
+ (sort renderers
+ string-ci:\"/\\\\|?*]"
+ (format "~a" value)
+ "_"))
+
+(define (resource-extension resource)
+ (let* ((uri (send resource get-uri))
+ (without-query
+ (regexp-replace #px"[?#].*$" uri ""))
+ (uri-extension
+ (regexp-match #px"(?i:[.]([a-z0-9]{1,8})$)"
+ without-query))
+ (mime-type (send resource get-mime-type)))
+ (cond
+ (uri-extension
+ (string-append "."
+ (string-downcase
+ (cadr uri-extension))))
+ ((member mime-type
+ '("audio/flac"
+ "audio/x-flac"
+ "application/flac")) ".flac")
+ ((or (equal? mime-type "audio/mpeg")
+ (equal? mime-type "audio/mp3")) ".mp3")
+ ((or (equal? mime-type "audio/opus")
+ (equal? mime-type "audio/ogg")) ".opus")
+ ((member mime-type
+ '("audio/wav"
+ "audio/wave"
+ "audio/x-wav")) ".wav")
+ ((member mime-type
+ '("audio/mp4"
+ "audio/x-m4a")) ".m4a")
+ ((equal? mime-type "audio/aac") ".aac")
+ ((equal? mime-type "audio/x-ms-wma") ".wma")
+ (else ".audio"))))
+
+(define (content-length headers)
+ (for/or ((header (in-list headers)))
+ (let ((matched
+ (regexp-match
+ #px#"(?i:^content-length:[ \t]*([0-9]+)[ \t]*$)"
+ header)))
+ (and matched
+ (string->number
+ (bytes->string/utf-8
+ (cadr matched)))))))
+
+(define (successful-status? status)
+ (regexp-match? #px#"^HTTP/[0-9.]+ 2[0-9][0-9]" status))
+
+(define (clear-playlist-cache! [playlist-id #f])
+ (let ((target
+ (if playlist-id
+ (build-path (playlist-cache-root)
+ (safe-name playlist-id))
+ (playlist-cache-root))))
+ (when (directory-exists? target)
+ (with-handlers ([exn:fail? (lambda (e) (void))])
+ (delete-directory/files target)))))
+
+(define playlist-cache%
+ (class object%
+ (init-field
+ playlist-id
+ [updated (lambda (entry downloaded total) (void))])
+
+ (define directory
+ (build-path (playlist-cache-root)
+ (safe-name playlist-id)))
+
+ (define queue
+ (make-async-channel))
+
+ (define generations
+ (make-hash))
+
+ (define stopped?
+ #f)
+
+ (define worker-custodian
+ (make-custodian))
+
+ (define/private (entry-generation entry)
+ (hash-ref generations
+ (send entry get-id)
+ 0))
+
+ (define/private (next-generation! entry)
+ (hash-update! generations
+ (send entry get-id)
+ add1
+ 0)
+ (entry-generation entry))
+
+ (define/private (cache-file entry)
+ (let ((resource
+ (send (send entry get-track)
+ get-resource)))
+ (build-path directory
+ (string-append
+ (safe-name (send entry get-id))
+ (resource-extension resource)))))
+
+ (define/private (notify! entry downloaded total)
+ (with-handlers
+ ((exn:fail?
+ (lambda (exception)
+ (warn-rktplayer
+ "Cache status callback failed: ~a"
+ (exn-message exception)))))
+ (updated entry downloaded total)))
+
+ (define/private (copy-download!
+ input temporary entry total)
+ (let ((downloaded 0)
+ (last-reported 0)
+ (buffer (make-bytes 65536)))
+ (dynamic-wind
+ void
+ (lambda ()
+ (call-with-output-file
+ temporary
+ (lambda (output)
+ (let loop ()
+ (let ((count
+ (read-bytes-avail!* buffer input)))
+ (unless (eof-object? count)
+ (write-bytes buffer output 0 count)
+ (set! downloaded (+ downloaded count))
+ (when (>= (- downloaded last-reported)
+ 1048576)
+ (set! last-reported downloaded)
+ (notify! entry downloaded total))
+ (loop)))))
+ #:exists 'replace
+ #:mode 'binary))
+ (lambda ()
+ (close-input-port input)))
+ downloaded))
+
+ (define/private (finish-download!
+ entry generation target temporary
+ downloaded total)
+ (if (and (not stopped?)
+ (= generation
+ (entry-generation entry)))
+ (begin
+ (when (file-exists? target)
+ (delete-file target))
+ (rename-file-or-directory temporary target)
+ (send entry set-cache-file! target)
+ (notify! entry downloaded total))
+ (when (file-exists? temporary)
+ (delete-file temporary))))
+
+ (define/private (download! entry generation)
+ (let* ((resource
+ (send (send entry get-track)
+ get-resource))
+ (uri (send resource get-uri))
+ (target (cache-file entry))
+ (temporary
+ (string->path
+ (string-append (path->string target)
+ ".part"))))
+ (let ((finished? #f))
+ (dynamic-wind
+ void
+ (lambda ()
+ (make-directory* directory)
+ (let-values
+ (((status headers input)
+ (http-sendrecv/url
+ (string->url uri)
+ #:headers
+ (list "Connection: close"))))
+ (unless (successful-status? status)
+ (close-input-port input)
+ (error 'playlist-cache%
+ "download failed for ~a: ~a"
+ uri
+ status))
+ (let* ((total (content-length headers))
+ (downloaded
+ (copy-download!
+ input temporary entry total)))
+ (finish-download!
+ entry generation target temporary
+ downloaded total)
+ (set! finished? #t))))
+ (lambda ()
+ (when (and (not finished?)
+ (file-exists? temporary))
+ (delete-file temporary)))))))
+
+ (define worker
+ (parameterize
+ ((current-custodian worker-custodian))
+ (thread
+ (lambda ()
+ (let loop ()
+ (let ((request (async-channel-get queue)))
+ (unless (eq? request 'stop)
+ (let ((entry (car request))
+ (generation (cadr request)))
+ (with-handlers
+ ((exn:fail?
+ (lambda (exception)
+ (when (= generation
+ (entry-generation entry))
+ (send entry
+ set-cache-failed!
+ (exn-message exception))
+ (notify! entry 0 #f)))))
+ (download! entry generation))
+ (loop)))))))))
+
+ (define/public (ensure-entry! entry)
+ (let ((track (send entry get-track)))
+ (when track
+ (let* ((resource (send track get-resource))
+ (file (send resource get-file)))
+ (cond
+ (file
+ (send entry set-cache-file! file))
+ ((regexp-match? #px"(?i:^https?://)"
+ (send resource get-uri))
+ (let ((target (cache-file entry)))
+ (if (file-exists? target)
+ (send entry set-cache-file! target)
+ (let ((generation
+ (next-generation! entry)))
+ (send entry set-cache-downloading!)
+ (notify! entry 0 #f)
+ (async-channel-put
+ queue
+ (list entry generation)))))))))))
+
+ (define/public (drop-entry! entry)
+ (next-generation! entry)
+ (let ((file (send entry get-cache-file)))
+ (when (and file
+ (path? file)
+ (file-exists? file)
+ (equal? (simplify-path directory)
+ (simplify-path
+ (path-only file))))
+ (delete-file file))))
+
+ (define/public (clear!)
+ (when (directory-exists? directory)
+ (delete-directory/files directory)))
+
+ (define/public (stop!)
+ (unless stopped?
+ (set! stopped? #t)
+ (custodian-shutdown-all
+ worker-custodian)))
+
+ (super-new)))
diff --git a/play/playlist-entry.rkt b/play/playlist-entry.rkt
new file mode 100644
index 0000000..d94b6aa
--- /dev/null
+++ b/play/playlist-entry.rkt
@@ -0,0 +1,194 @@
+#lang racket/base
+
+(require racket/class
+ "../library/library-factory.rkt"
+ "../library/track-store.rkt"
+ "../library/base/track.rkt"
+ "../misc/utils.rkt")
+
+(provide playlist-entry%
+ track->playlist-entry
+ store->playlist-entry)
+
+(define playlist-entry%
+ (class object%
+ (init-field
+ stored
+ [track #f])
+
+ (check/c* playlist-entry%
+ (stored track-store?)
+ (track (or/c #f (is-a?/c track<%>))))
+
+ (define/public (is-valid?)
+ (not (eq? track #f)))
+
+ (define/public (get-track)
+ track)
+
+ (define cache-file
+ (and track
+ (send (send track get-resource)
+ get-file)))
+
+ (define cache-status
+ (if cache-file 'available 'unavailable))
+
+ (define cache-error
+ #f)
+
+ (define/public (get-cache-file)
+ (if (and cache-file
+ (file-exists? cache-file))
+ cache-file
+ (begin
+ (set! cache-file #f)
+ (unless (eq? cache-status 'downloading)
+ (set! cache-status 'unavailable))
+ #f)))
+
+ (define/public (get-cache-status)
+ cache-status)
+
+ (define/public (get-cache-error)
+ cache-error)
+
+ (define/public (is-available?)
+ (and (send this is-valid?)
+ (eq? cache-status 'available)
+ (send this get-cache-file)
+ #t))
+
+ (define/public (set-cache-downloading!)
+ (set! cache-file #f)
+ (set! cache-status 'downloading)
+ (set! cache-error #f))
+
+ (define/public (set-cache-file! file)
+ (set! cache-file file)
+ (set! cache-status 'available)
+ (set! cache-error #f))
+
+ (define/public (set-cache-failed! message)
+ (set! cache-file #f)
+ (set! cache-status 'failed)
+ (set! cache-error message))
+
+ (define/public (get-id)
+ (track-store-id stored))
+
+ (define/public (get-number)
+ (if track
+ (send track get-number)
+ (track-store-number stored)))
+
+ (define/public (get-title)
+ (if track
+ (send track get-title)
+ (track-store-title stored)))
+
+ (define/public (get-artist)
+ (if track
+ (send track get-artist)
+ ""))
+
+ (define/public (get-album)
+ (if track
+ (send track get-album)
+ ""))
+
+ (define/public (get-length)
+ (if track
+ (send track get-length)
+ 0))
+
+ (define/public (->store)
+ stored)
+
+ (super-new)))
+
+(define (track->playlist-entry track)
+ (check/c track->playlist-entry
+ track
+ (is-a?/c track<%>))
+
+ (new playlist-entry%
+ [stored (track->store track)]
+ [track track]))
+
+(define (store->playlist-entry stored factory)
+ (check/c store->playlist-entry
+ factory
+ (is-a?/c library-factory%))
+
+ (and (track-store? stored)
+ (new playlist-entry%
+ [stored stored]
+ [track (store->track stored factory)])))
+
+(module+ test
+ (require rackunit
+ "../library/library-ref.rkt"
+ "../library/track-filesystem.rkt")
+
+ (define stored
+ (list 'track
+ 1
+ 'playlist-track
+ 3
+ "Stored title"
+ (library-ref
+ 'test-library
+ 'filesystem
+ 1)
+ 'file
+ (list (string->path "track.mp3"))))
+
+ (define invalid-entry
+ (new playlist-entry%
+ [stored stored]))
+
+ (check-false (send invalid-entry is-valid?))
+ (check-false (send invalid-entry get-track))
+ (check-equal? (send invalid-entry get-id)
+ 'playlist-track)
+ (check-equal? (send invalid-entry get-number) 3)
+ (check-equal? (send invalid-entry get-title)
+ "Stored title")
+ (check-equal? (send invalid-entry get-artist) "")
+ (check-equal? (send invalid-entry get-album) "")
+ (check-equal? (send invalid-entry get-length) 0)
+ (check-equal? (send invalid-entry ->store)
+ stored)
+
+ (define cfg%
+ (class object%
+ (define/public (get-id) 'test-library)
+ (define/public (get-kind) 'filesystem)
+ (define/public (get-kind-version) 1)
+ (super-new)))
+
+ (define library%
+ (class object%
+ (define/public (resolve-path relative-path)
+ (apply build-path relative-path))
+ (define/public (get-cfg)
+ (new cfg%))
+ (super-new)))
+
+ (define track
+ (new track-filesystem%
+ [library (new library%)]
+ [relative-path
+ (list (string->path "track.mp3"))]))
+
+ (define valid-entry
+ (track->playlist-entry track))
+
+ (check-true (send valid-entry is-valid?))
+ (check-eq? (send valid-entry get-track) track)
+ (check-equal? (send valid-entry get-title)
+ (send track get-title))
+ (check-true
+ (track-store?
+ (send valid-entry ->store))))
diff --git a/play/playlist-gui.rkt b/play/playlist-gui.rkt
new file mode 100644
index 0000000..82315a9
--- /dev/null
+++ b/play/playlist-gui.rkt
@@ -0,0 +1,218 @@
+#lang racket/base
+
+(require racket/class
+ racket-sprintf
+ racket/string
+ racket-webview
+ xml
+ "../misc/utils.rkt")
+
+(provide playlist-gui%)
+
+(define (track-length->string length-seconds)
+ (let* ((whole-seconds
+ (inexact->exact
+ (round length-seconds)))
+ (hours (quotient whole-seconds 3600))
+ (minutes
+ (quotient (remainder whole-seconds 3600)
+ 60))
+ (seconds
+ (remainder (remainder whole-seconds 3600)
+ 60)))
+ (sprintf "%02d:%02d:%02d"
+ hours minutes seconds)))
+
+(define (entry-tooltip entry)
+ (let* ((track (send entry get-track))
+ (uri
+ (and track
+ (send (send track get-resource)
+ get-uri))))
+ (string-join
+ (filter
+ (lambda (value)
+ (and (string? value)
+ (not (string=? value ""))))
+ (list
+ (send entry get-title)
+ (send entry get-artist)
+ (send entry get-album)
+ uri
+ (and (eq? (send entry get-cache-status)
+ 'failed)
+ (send entry get-cache-error))))
+ "\n")))
+
+(define (track-row playlist track-idx current-track-nr)
+ (let* ((entry (send playlist entry track-idx))
+ (track-id (send playlist track-id track-idx))
+ (row-class
+ (cond
+ ((not (send entry is-valid?))
+ "track invalid")
+ ((not (send entry is-available?))
+ (format "track unavailable ~a"
+ (send entry get-cache-status)))
+ ((equal? track-idx current-track-nr)
+ "track current")
+ (else "track"))))
+ (list
+ 'tr
+ (list (list 'id (format "~a" track-id))
+ (list 'class row-class)
+ (list 'title (entry-tooltip entry))
+ (list 'draggable "true"))
+ (list 'td
+ '((class "number"))
+ (format "~a." (send entry get-number)))
+ (list 'td
+ '((class "title"))
+ (send entry get-title))
+ (list 'td
+ '((class "album"))
+ (send entry get-album))
+ (list 'td
+ '((class "length"))
+ (track-length->string
+ (send entry get-length))))))
+
+(define (playlist->html playlist current-track-nr)
+ (xexpr->string
+ (append
+ (list 'table '((class "tracks")))
+ (for/list ((track-idx
+ (in-range (send playlist length))))
+ (track-row playlist
+ track-idx
+ current-track-nr))
+ (list
+ (list 'tr '((class "unresponsive")))))))
+
+(define playlist-gui%
+ (class object%
+ (init-field
+ window
+ element
+ play-track-callback
+ playlist-changed-callback)
+
+ (check/c* playlist-gui%
+ (window object?)
+ (element object?)
+ (play-track-callback procedure?)
+ (playlist-changed-callback procedure?))
+
+ (define dragged-from-idx
+ #f)
+
+ (define/private (row-index playlist element)
+ (send playlist
+ index
+ (send element attr/symbol 'id)))
+
+ (define/private (bind-row-events! playlist)
+ (send window
+ bind!
+ "table.tracks tr.track"
+ '(click contextmenu)
+ (lambda (row event data)
+ (case event
+ ((click)
+ (let ((track-idx
+ (row-index playlist row)))
+ (when (send (send playlist entry track-idx)
+ is-available?)
+ (play-track-callback track-idx))))
+ ((contextmenu)
+ (let* ((track-id (send row id))
+ (menu
+ (wv-menu
+ 'track-menu
+ (wv-menu-item
+ 'm-drop-track
+ "Drop track"
+ #:callback
+ (lambda ()
+ (send playlist drop-id track-id)
+ (playlist-changed-callback)))))
+ (client-x (hash-ref data 'clientX 60))
+ (client-y (hash-ref data 'clientY 60)))
+ (send window
+ popup-menu!
+ menu
+ client-x
+ client-y))))))
+
+ (send window
+ bind!
+ "table.tracks tr.track"
+ 'dragstart
+ (lambda (row event data)
+ (set! dragged-from-idx
+ (row-index playlist row)))
+ #t)
+
+ (send window
+ bind!
+ "table.tracks tr.track"
+ '(dragover drop)
+ (lambda (row event data)
+ (when (eq? event 'drop)
+ (let ((drop-at-idx
+ (row-index playlist row)))
+ (when (and (integer? dragged-from-idx)
+ (integer? drop-at-idx)
+ (not (= dragged-from-idx
+ drop-at-idx)))
+ (send playlist
+ move-track
+ dragged-from-idx
+ drop-at-idx)
+ (set! dragged-from-idx #f)
+ (playlist-changed-callback)))))))
+
+ (define/public (update! playlist current-track-nr)
+ (let ((html
+ (playlist->html playlist
+ current-track-nr)))
+ (send element set-innerHTML! html)
+ (bind-row-events! playlist)
+ (void)))
+
+ (super-new)))
+
+(module+ test
+ (require rackunit)
+
+ (define test-entry%
+ (class object%
+ (define/public (is-valid?) #t)
+ (define/public (get-number) 3)
+ (define/public (get-title) "Title")
+ (define/public (get-artist) "Artist")
+ (define/public (get-album) "Album")
+ (define/public (get-length) 65)
+ (define/public (get-track) #f)
+ (define/public (get-cache-status) 'available)
+ (define/public (get-cache-error) #f)
+ (define/public (is-available?) #t)
+ (super-new)))
+
+ (define test-playlist%
+ (class object%
+ (define/public (length) 1)
+ (define/public (entry idx)
+ (new test-entry%))
+ (define/public (track-id idx)
+ 'track-1)
+ (super-new)))
+
+ (define html
+ (playlist->html (new test-playlist%) 0))
+
+ (check-true (string-contains? html "track current"))
+ (check-true (string-contains? html "draggable"))
+ (check-true (string-contains? html "00:01:05"))
+ (check-equal? (track-length->string 1365.797)
+ "00:22:46"))
diff --git a/play/playlist.rkt b/play/playlist.rkt
new file mode 100644
index 0000000..f01c715
--- /dev/null
+++ b/play/playlist.rkt
@@ -0,0 +1,487 @@
+#lang racket/base
+
+(require keystore/class
+ racket/class
+ racket/list
+ "../library/library-factory.rkt"
+ "../library/base/media-item.rkt"
+ "playlist-cache.rkt"
+ "playlist-entry.rkt"
+ "../misc/utils.rkt")
+
+(provide playlist%)
+
+(define list-length
+ length)
+
+(define list-for-each
+ for-each)
+
+(define (valid-track-index? entries idx)
+ (and (exact-nonnegative-integer? idx)
+ (< idx (list-length entries))
+ (send (list-ref entries idx)
+ is-valid?)))
+
+(define (available-track-index? entries idx)
+ (and (exact-nonnegative-integer? idx)
+ (< idx (list-length entries))
+ (send (list-ref entries idx)
+ is-available?)))
+
+(define (first-valid-index entries indexes)
+ (for/first ((idx indexes)
+ #:when
+ (valid-track-index? entries idx))
+ idx))
+
+(define (first-available-index entries indexes)
+ (for/first ((idx indexes)
+ #:when
+ (available-track-index? entries idx))
+ idx))
+
+(define playlist%
+ (class object%
+ (init-field
+ [max-tracks 100]
+ [name "Default"]
+ [id #f]
+ [settings #f]
+ [cache-updated
+ (lambda (entry downloaded total) (void))])
+
+ (check/c playlist% max-tracks exact-positive-integer?)
+
+ (define store
+ (new keystore%
+ [file 'rktplayer]))
+
+ (define entries
+ '())
+
+ (define cache
+ #f)
+
+ (define factory
+ (get-library-factory))
+
+ (define/private (can-add?)
+ (< (list-length entries)
+ max-tracks))
+
+ (define/private (set-cache! playlist-id)
+ (when cache
+ (send cache stop!))
+ (set! cache
+ (new playlist-cache%
+ [playlist-id playlist-id]
+ [updated cache-updated]))
+ (list-for-each
+ (lambda (entry)
+ (send cache ensure-entry! entry))
+ entries))
+
+ (define/private (add-track* track)
+ (when (can-add?)
+ (let ((entry
+ (track->playlist-entry track)))
+ (set! entries
+ (append entries
+ (list entry)))
+ (when cache
+ (send cache ensure-entry! entry)))))
+
+ (define/private (add-media-item* item)
+ (when (can-add?)
+ (let ((track (send item get-track))
+ (container (send item get-container)))
+ (cond
+ (track
+ (add-track* track))
+ (container
+ (list-for-each
+ (lambda (child)
+ (add-media-item* child))
+ (send container get-items)))))))
+
+ (define/private (sort-entries!)
+ (set! entries
+ (sort
+ entries
+ (lambda (entry-1 entry-2)
+ (let ((track-1 (send entry-1 get-track))
+ (track-2 (send entry-2 get-track)))
+ (and track-1
+ (or (not track-2)
+ (send track-1
+ track<
+ track-2))))))))
+
+ (define/public (tabs)
+ (map
+ (lambda (key)
+ (if (string? key)
+ (string->symbol key)
+ key))
+ (send store
+ get
+ 'tabs
+ '(tabkey-default))))
+
+ (define/public (tab-count)
+ (list-length (send this tabs)))
+
+ (define/public (make-tab-key)
+ (string->symbol
+ (format "tabkey-~a-~a"
+ (current-milliseconds)
+ (random 10000))))
+
+ (define/public (get-tab-name idx)
+ (let* ((tabs (send this tabs))
+ (tab-id (list-ref tabs idx))
+ (stored
+ (send store
+ get
+ tab-id
+ (list
+ (format "Playlist-~a" idx)
+ '()))))
+ (car stored)))
+
+ (define/public (set-tab-name! idx new-name)
+ (check/c playlist% set-tab-name!
+ new-name
+ string?)
+
+ (let* ((tabs (send this tabs))
+ (tab-id (list-ref tabs idx))
+ (stored
+ (send store
+ get
+ tab-id
+ (list
+ (format "Playlist-~a" idx)
+ '()))))
+ (send store
+ set!
+ tab-id
+ (list new-name
+ (cadr stored)))))
+
+ (define/public (tab-id idx)
+ (list-ref (send this tabs)
+ idx))
+
+ (define/public (tab-index tab-id)
+ (index-of (send this tabs)
+ tab-id
+ eq?))
+
+ (define/public (drop-tab! idx)
+ (let* ((tabs (send this tabs))
+ (tab-id (list-ref tabs idx)))
+ (when (eq? id tab-id)
+ (when cache
+ (send cache stop!))
+ (set! cache #f))
+ (clear-playlist-cache! tab-id)
+ (send store
+ set!
+ 'tabs
+ (list-drop! tabs idx))
+ (send store drop! tab-id)))
+
+ (define/public (add-tab!)
+ (let ((tab-id (send this make-tab-key)))
+ (send store
+ set!
+ 'tabs
+ (append (send this tabs)
+ (list tab-id)))))
+
+ (define/public (save-tab!)
+ (let ((idx (send this tab-index id)))
+ (dbg-rktplayer "entry id = ~a, ~a" id idx)
+ (if idx
+ (send store
+ set!
+ id
+ (list
+ (send this get-tab-name idx)
+ (map
+ (lambda (entry)
+ (send entry ->store))
+ entries)))
+ (err-rktplayer
+ "Cannot get tab for id ~a"
+ id))))
+
+ (define/public (load-tab idx)
+ (let* ((tabs (send this tabs))
+ (tab-id (list-ref tabs idx))
+ (stored
+ (send store
+ get
+ tab-id
+ (list "Default" '()))))
+ (dbg-rktplayer "loading ~a" tab-id)
+ (set! id tab-id)
+ (set! name (car stored))
+ (set! entries
+ (filter-map
+ (lambda (stored-track)
+ (store->playlist-entry
+ stored-track
+ factory))
+ (cadr stored)))
+ (set-cache! tab-id))
+ #t)
+
+ (define/public (length)
+ (list-length entries))
+
+ (define/public (first-valid-track-index)
+ (first-valid-index
+ entries
+ (in-range (list-length entries))))
+
+ (define/public (first-available-track-index)
+ (first-available-index
+ entries
+ (in-range (list-length entries))))
+
+ (define/public (next-valid-track-index idx
+ [wrap? #f])
+ (check/c* (playlist% next-valid-track-index)
+ (idx exact-nonnegative-integer?)
+ (wrap? boolean?))
+
+ (or
+ (first-valid-index
+ entries
+ (in-range (+ idx 1)
+ (list-length entries)))
+ (and wrap?
+ (first-valid-index
+ entries
+ (in-range
+ (min (+ idx 1)
+ (list-length entries)))))))
+
+ (define/public (next-available-track-index idx
+ [wrap? #f])
+ (check/c* (playlist% next-available-track-index)
+ (idx exact-nonnegative-integer?)
+ (wrap? boolean?))
+
+ (or
+ (first-available-index
+ entries
+ (in-range (+ idx 1)
+ (list-length entries)))
+ (and wrap?
+ (first-available-index
+ entries
+ (in-range
+ (min (+ idx 1)
+ (list-length entries)))))))
+
+ (define/public (previous-valid-track-index idx
+ [wrap? #f])
+ (check/c* (playlist% previous-valid-track-index)
+ (idx exact-nonnegative-integer?)
+ (wrap? boolean?))
+
+ (or
+ (first-valid-index
+ entries
+ (in-range (- idx 1)
+ -1
+ -1))
+ (and wrap?
+ (first-valid-index
+ entries
+ (in-range
+ (- (list-length entries) 1)
+ (- idx 1)
+ -1)))))
+
+ (define/public (previous-available-track-index idx
+ [wrap? #f])
+ (check/c* (playlist% previous-available-track-index)
+ (idx exact-nonnegative-integer?)
+ (wrap? boolean?))
+
+ (or
+ (first-available-index
+ entries
+ (in-range (- idx 1)
+ -1
+ -1))
+ (and wrap?
+ (first-available-index
+ entries
+ (in-range
+ (- (list-length entries) 1)
+ (- idx 1)
+ -1)))))
+
+ (define/public (add-track track . save?)
+ (add-track* track)
+ (when (null? save?)
+ (send this save-tab!)))
+
+ (define/public (add-media-item item . save?)
+ (check/c playlist% add-media-item
+ item
+ (is-a?/c media-item%))
+
+ (add-media-item* item)
+ (when (null? save?)
+ (send this save-tab!)))
+
+ (define/public (replace-with-media-item! item)
+ (check/c playlist% replace-with-media-item!
+ item
+ (is-a?/c media-item%))
+
+ (when cache
+ (send cache stop!))
+ (clear-playlist-cache! id)
+ (set! entries '())
+ (set! cache #f)
+ (set-cache! id)
+ (add-media-item* item)
+ (sort-entries!)
+ (send this save-tab!))
+
+ (define/public (move-track from-idx to-idx)
+ (unless (= from-idx to-idx)
+ (let* ((entry (list-ref entries from-idx))
+ (target-idx
+ (if (< from-idx to-idx)
+ (- to-idx 1)
+ to-idx))
+ (without-entry
+ (append
+ (take entries from-idx)
+ (drop entries (+ from-idx 1)))))
+ (set! entries
+ (append
+ (take without-entry target-idx)
+ (list entry)
+ (drop without-entry target-idx)))
+ (send this save-tab!))))
+
+ (define/public (drop-id track-id)
+ (let* ((idx (send this index track-id))
+ (entry (list-ref entries idx)))
+ (set! entries
+ (append
+ (take entries idx)
+ (drop entries (+ idx 1))))
+ (when (and cache
+ (not
+ (findf
+ (lambda (other)
+ (equal? (send other get-id)
+ (send entry get-id)))
+ entries)))
+ (send cache drop-entry! entry))
+ (send this save-tab!)))
+
+ (define/public (entry idx)
+ (list-ref entries idx))
+
+ (define/public (track idx)
+ (send (send this entry idx)
+ get-track))
+
+ (define/public (track-file idx)
+ (send (send this entry idx)
+ get-cache-file))
+
+ (define/public (cache-all!)
+ (when cache
+ (list-for-each
+ (lambda (entry)
+ (send cache ensure-entry! entry))
+ entries)))
+
+ (define/public (reset-cache!)
+ (when cache
+ (send cache stop!))
+ (clear-playlist-cache!)
+ (set! cache #f)
+ (set-cache! id))
+
+ (define/public (stop-cache!)
+ (when cache
+ (send cache stop!)
+ (set! cache #f)))
+
+ (define/public (display-tracks)
+ (list-for-each
+ (lambda (entry)
+ (let ((track (send entry get-track)))
+ (if track
+ (send track ->log)
+ (warn-rktplayer
+ "Unavailable track: ~a"
+ (send entry get-title)))))
+ entries))
+
+ (define/public (for-each proc)
+ (for ((entry (in-list entries))
+ (idx (in-naturals)))
+ (proc idx
+ (send entry get-track))))
+
+ (define/public (track-id idx)
+ (string->symbol
+ (format "track-~a"
+ (+ idx 1))))
+
+ (define/public (index track-id)
+ (- (string->number
+ (substring
+ (symbol->string track-id)
+ 6))
+ 1))
+
+ (super-new)
+
+ (send this load-tab 0)))
+
+(module+ test
+ (require rackunit)
+
+ (define test-entry%
+ (class object%
+ (init-field valid?)
+ (define/public (is-valid?) valid?)
+ (define/public (is-available?) valid?)
+ (super-new)))
+
+ (define entries
+ (list
+ (new test-entry% [valid? #f])
+ (new test-entry% [valid? #t])
+ (new test-entry% [valid? #f])
+ (new test-entry% [valid? #t])))
+
+ (check-equal?
+ (first-valid-index
+ entries
+ (in-range (list-length entries)))
+ 1)
+ (check-equal?
+ (first-valid-index entries (in-range 2 4))
+ 3)
+ (check-false
+ (first-valid-index entries (in-range 4 4)))
+ (check-equal?
+ (first-valid-index entries (in-range 2 -1 -1))
+ 1))
diff --git a/play/renderer-sonos.rkt b/play/renderer-sonos.rkt
new file mode 100644
index 0000000..63aee08
--- /dev/null
+++ b/play/renderer-sonos.rkt
@@ -0,0 +1,29 @@
+#lang racket/base
+
+(require racket/class
+ racket-sonos
+ "renderer-upnp.rkt")
+
+(provide renderer-sonos%)
+
+(define renderer-sonos%
+ (class renderer-upnp%
+ (init-field sonos-group)
+ (init preferences)
+
+ (define/public (get-sonos-group)
+ sonos-group)
+
+ (super-new
+ [upnp-device
+ (sonos-group-renderer
+ sonos-group)]
+ [preferences preferences]
+ [id
+ (format "sonos:~a"
+ (sonos-group-id
+ sonos-group))]
+ [name
+ (sonos-group-name
+ sonos-group)]
+ [kind 'sonos])))
diff --git a/play/renderer-upnp.rkt b/play/renderer-upnp.rkt
new file mode 100644
index 0000000..a3712e2
--- /dev/null
+++ b/play/renderer-upnp.rkt
@@ -0,0 +1,35 @@
+#lang racket/base
+
+(require racket/class
+ racket-upnp
+ "base/renderer.rkt"
+ "../misc/utils.rkt")
+
+(provide renderer-upnp%)
+
+(define renderer-upnp%
+ (class renderer%
+ (init-field upnp-device)
+ (init
+ preferences
+ [name #f]
+ [id #f]
+ [kind 'upnp])
+
+ (check/c renderer-upnp%
+ upnp-device
+ media-renderer?)
+
+ (super-new
+ [id
+ (format "~a"
+ (or id
+ (upnp-device-udn upnp-device)
+ (upnp-device-address
+ upnp-device)))]
+ [name
+ (or name
+ (media-renderer-name upnp-device))]
+ [kind kind]
+ [device upnp-device]
+ [preferences preferences])))
diff --git a/playlist.rkt b/playlist.rkt
deleted file mode 100644
index b45bb5d..0000000
--- a/playlist.rkt
+++ /dev/null
@@ -1,438 +0,0 @@
-#lang racket
-
-(require racket/class
- "music-library.rkt"
- racket-audio
- "utils.rkt"
- racket-sprintf
- keystore/class
- racket/list
- )
-
-(provide track%
- playlist%
- )
-
-(define the-displayln displayln)
-(define list-for-each for-each)
-(define list-length length)
-
-(define next-track-id 0)
-
-(define track%
- (class object%
- (init-field
- [file #f]
- [title ""]
- [artist ""]
- [album ""]
- [length 0]
- [number 0]
- )
-
- (define/public (displayln)
- (the-displayln (format "~a - ~a - ~a - ~a"
- number
- title
- album
- length)))
-
- (define my-id (begin
- (set! next-track-id (+ next-track-id 1))
- (when (> next-track-id 10000000)
- (set! next-track-id 1))
- next-track-id))
-
- (define/public (get-file) file)
- (define/public (get-title) title)
- (define/public (get-artist) artist)
- (define/public (get-album) album)
- (define/public (get-number) number)
- (define/public (get-length) length)
- (define/public (get-id) my-id)
-
- (define/public (booklet-file)
- (let* ((dir (path-only file))
- (booklet-file (build-path dir "booklet.pdf")))
- booklet-file))
-
- (define/public (has-booklet?)
- (file-exists? (send this booklet-file)))
-
- (define/public (track< t2)
- (if (string-cistring file) file))
- (tags (id3-tags f))
- (tmpfile #f))
- (unless (tags-valid? tags)
- (let ((nfile (make-temporary-file "rktplayer-~a" #:copy-from f)))
- (set! tags (id3-tags nfile))
- (set! tmpfile nfile)
- ))
- (unless (eq? tmpfile #f)
- (delete-file tmpfile))
- tags
- )
- )
-
- (define/public (image->file* to-file)
- #f)
-
- (define/public (image->file to-file*)
- (let ((to-file (format "~a" to-file*))
- (tags (read-tags)))
- (dbg-rktplayer "image->file ~a" to-file)
- (let ((image-from-tags (λ ()
- (if (tags-valid? tags)
- (let ((ext (tags-picture->ext tags)))
- (if (eq? ext #f)
- #f
- (let ((path (string-append to-file "." (symbol->string ext))))
- (if (tags-picture->file tags path)
- path
- #f)
- )
- )
- )
- #f)
- )
- )
- )
- (let ((path (image-from-tags)))
- (dbg-rktplayer "image-from-tags: ~a" path)
- (if (eq? path #f)
- (let* ((bd (basedir file))
- (files (filter
- (λ (f)
- (let ((file (build-path bd f)))
- (file-exists? file)))
- (list "cover.jpg" "cover.png" "folder.jpg" "folder.png"))))
- (if (null? files)
- #f
- (let ((file (string-append to-file (bytes->string/utf-8 (path-get-extension (car files))))))
- (copy-file (build-path bd (car files)) file #:exists-ok? #t)
- (dbg-rktplayer "image from basedir: ~a" file)
- (format "~a" file))
- ))
- path))
- )
- )
- )
-
- (define/public (image->mimetype*)
- #f)
-
- (define/public (image->mimetype)
- (let ((tags (read-tags)))
- (if (tags-valid? tags)
- (tags-picture->mimetype tags)
- 'no-mimetype)))
-
- (super-new)
-
- (begin
- (let ((use-tags #t))
- (if use-tags
- (unless (eq? file #f)
- (let ((tags (read-tags)))
- (if (tags-valid? tags)
- (begin
- (set! title (tags-title tags))
- (set! artist (tags-artist tags))
- (set! album (tags-album tags))
- (set! number (tags-track tags))
- (set! length (tags-length tags))
- )
- (begin
- (set! title "invalid tags")
- (set! artist "invalid tags")
- (set! album "invalid tags")
- (set! number number)
- (set! length -1)
- )
- )
- )
- )
- (unless (eq? file #f)
- (set! title (format "~a" file))
- (set! number 0))
- )
- )
- )
- )
- )
-
-(define list-len length)
-(define orig-for-each for-each)
-
-(define playlist%
- (class object%
- (init-field
- [start-map #f]
- [max-tracks 100]
- [name "Default"]
- [id #f]
- [settings #f]
- )
-
- (define store (new keystore% [file 'rktplayer]))
- (define tracks '())
-
- (define (can-add? file)
- (and (<= (list-len tracks) max-tracks)
- (is-music-file? file)))
-
- (define (add-track* file)
- (let ((track (new track% [file file])))
- (set! tracks (append tracks (list track)))))
-
- (define (read-tracks-internal dir)
- ;(displayln (format "dir = ~a" dir))
- (if (> (list-len tracks) max-tracks)
- 'done
- (if (file-exists? dir)
- (when (can-add? dir)
- (add-track dir))
- (if (directory-exists? dir)
- (let ((content (directory-list dir)))
- (orig-for-each (λ (entry)
- (let ((p (build-path dir entry)))
- (if (directory-exists? p)
- (read-tracks-internal p)
- (when (and (file-exists? p) (can-add? p))
- ;(displayln (format "Adding ~a" p))
- (add-track* p)))))
- content))
- 'no-file-or-dir
- )
- )
- )
- )
-
- ;(define/public (set-name! n)
- ; (set! name n))
-
- ;(define/public (set-id! id*)
- ; (set! id id*))
-
- ;(define/public (get-id)
- ; id)
-
- ;(define/public (get-name)
- ; name)
-
- (define/public (tabs)
- (map (λ (k)
- (if (string? k)
- (string->symbol k)
- k))
- (send store get 'tabs '(tabkey-default)))
- )
-
- (define/public (tab-count)
- (list-length (tabs)))
-
- (define/public (make-tab-key)
- (string->symbol
- (format "tabkey-~a-~a" (current-milliseconds) (random 10000))))
-
- (define/public (get-tab-name idx)
- (let* ((t (tabs))
- (entry (list-ref t idx)))
- (let ((v (send store get entry (list (format "Playlist-~a" idx) '()))))
- (car v))))
-
- (define/public (set-tab-name! idx name)
- (let* ((t (tabs))
- (entry (list-ref t idx))
- (v (send store get entry (list (format "Playlist-~a" idx) '())))
- )
- (send store set! entry (list name (cadr v)))
- )
- )
-
- (define/public (tab-id idx)
- (let ((t (tabs)))
- (list-ref t idx)))
-
- (define/public (tab-index id)
- (let ((t (tabs)))
- (letrec ((f (λ (t idx)
- (if (null? t)
- #f
- (if (eq? (car t) id)
- idx
- (f (cdr t) (+ idx 1)))))))
- (f t 0))))
-
- (define/public (drop-tab! idx)
- (let* ((t (tabs))
- (entry (list-ref t idx))
- )
- (send store set! 'tabs (list-drop! t idx))
- (send store drop! entry)
- ))
-
- (define/public (add-tab!)
- (let* ((t (tabs))
- (new-entry (send this make-tab-key)))
- (send store set! 'tabs (append t (list new-entry)))
- )
- )
-
- (define/public (save-tab!)
- (let* ((entry id)
- (idx (send this tab-index entry))
- )
- (dbg-rktplayer "entry id = ~a, ~a" entry idx)
- (if (eq? idx #f)
- (err-rktplayer "Cannot get tab for id ~a" entry)
- (let ((value (list (send this get-tab-name idx)
- (map (λ (track)
- (send track get-file))
- tracks))))
- (send store set! entry value)
- )
- )
- )
- )
-
- (define/public (load-tab idx)
- (let* ((t (tabs))
- (entry (list-ref t idx))
- )
- (dbg-rktplayer "loading ~a" entry)
- (set! id entry)
- (set! tracks '())
- (let ((value (send store get entry (list "Default" '()))))
- (set! name (car value))
- (list-for-each (λ (file)
- (when (file-exists? file)
- (send this add-track file #f)))
- (cadr value))
- )
- )
- #t
- )
-
- (define/public (read-tracks)
- (set! tracks '())
- (read-tracks-internal start-map)
- (set! tracks
- (sort tracks (λ (t1 t2)
- (send t1 track< t2))))
- (send this save-tab!)
- )
-
- (define/public (length)
- (list-len tracks))
-
- (define/public (add-track file . args)
- (add-track* file)
- (when (null? args)
- (send this save-tab!))
- )
-
- (define/public (move-track from-idx to-idx)
- (let ((tr (list-ref tracks from-idx))
- (idx 0))
- (if (= from-idx to-idx)
- #t
- (begin
- (when (< from-idx to-idx)
- (set! to-idx (- to-idx 1)))
- (let* ((l1 (if (= from-idx 0)
- '()
- (take tracks from-idx)))
- (l2 (drop tracks (+ from-idx 1)))
- (l (append l1 l2))
- )
- (set! tracks (append
- (if (= to-idx 0) '() (take l to-idx))
- (list tr)
- (drop l to-idx)))
- )
- (send this save-tab!)
- )
- )
- )
- )
-
- (define/public (drop-id track-id)
- (let ((idx (send this index track-id)))
- (let* ((l1 (if (= idx 0) '() (take tracks idx)))
- (l2 (drop tracks (+ idx 1)))
- (l (append l1 l2)))
- (set! tracks l)
- (send this save-tab!)
- )
- )
- )
-
- (define/public (track i)
- (list-ref tracks i))
-
- (define/public (display-tracks)
- (orig-for-each (λ (track)
- (send track displayln))
- tracks))
-
- (define/public (for-each f)
- (let ((idx 0))
- (orig-for-each (λ (track)
- (f idx track)
- (set! idx (+ idx 1)))
- tracks)
- )
- )
-
- (define/public (track-id i)
- (string->symbol (format "track-~a" (+ i 1))))
-
- (define/public (index id)
- (- (string->number (substring (symbol->string id) 6)) 1))
-
- (define/public (to-html)
- (define (formatter row)
- (let* ((track-idx (car row))
- (track (track track-idx)))
- (list
- (list 'td (list (list 'class "number"))
- (format "~a." (send track get-number)))
- (list 'td (list (list 'class "title"))
- (send track get-title))
- (list 'td (list (list 'class "album"))
- (send track get-album))
- (list 'td (list (list 'class "length"))
- (let* ((length-s (send track get-length))
- (hour (quotient length-s 3600))
- (min (quotient (remainder length-s 3600) 60))
- (sec (remainder (remainder length-s 3600) 60)))
- (sprintf "%02d:%02d:%02d" hour min sec)))
- )))
-
- (letrec ((f (λ (i N)
- (if (< i N)
- (cons (list (send this track-id i) i) (f (+ i 1) N))
- '()))))
- (dbg-rktplayer "Number of rows in playlist: ~a" (send this length))
- (let ((rows (f 0 (send this length))))
- (mktable rows 'tracks formatter))))
-
- (super-new)
-
- (begin
- (if (eq? start-map #f)
- (send this load-tab 0)
- (set! id (send this tab-id id)))
- )
- )
- )
-
\ No newline at end of file
diff --git a/rktplayer.rkt b/rktplayer.rkt
index 08c3da1..1131b00 100644
--- a/rktplayer.rkt
+++ b/rktplayer.rkt
@@ -1,20 +1,24 @@
#lang racket
(require racket/gui
- "gui.rkt"
- "tray.rkt"
- "translate.rkt"
+ "gui/gui.rkt"
+ "gui/tray.rkt"
+ "gui/translate.rkt"
+ "library/libraries-config.rkt"
+ "library/library-factory.rkt"
+ "library/library-filesystem.rkt"
+ "library/library-media-server.rkt"
simple-ini/class
racket-audio
racket-webview
racket/runtime-path
- "utils.rkt"
+ "misc/utils.rkt"
net/uri-codec
)
(provide run)
-(define-runtime-path rkt-gui-dir "gui")
+(define-runtime-path rkt-gui-dir "gui/html")
(define log-file (build-path (find-system-path 'cache-dir) ".rktplayer.log"))
@@ -63,10 +67,21 @@
[ini ini]
[file-getter my-file-getter]
))
+ (libraries-config
+ (new libraries-config%
+ [settings (send context settings 'settings)]))
+ (library-factory
+ (new library-factory%
+ [libraries-config libraries-config]))
)
+ (set-library-factory! library-factory)
+ (register-library-filesystem! library-factory)
+ (register-library-media-server! library-factory)
(displayln (format "ini file: ~a" (send ini get-file)))
(set-lang! (send ini get 'settings 'language 'en))
- (let* ((window (new rktplayer% [wv-context context] [log-file log-file]))
+ (let* ((window (new rktplayer%
+ [wv-context context]
+ [log-file log-file]))
(tray (new rktplayer-tray% [rktplayer-gui window]))
)
(set! rktplayer-window window)
@@ -117,4 +132,3 @@
)
;(run)
-
diff --git a/settings.rkt b/settings.rkt
deleted file mode 100644
index 1be1c97..0000000
--- a/settings.rkt
+++ /dev/null
@@ -1,274 +0,0 @@
-#lang racket
-
-(require racket-webview
- racket/runtime-path
- racket/gui
- racket-sprintf
- open-app
- xml
- "utils.rkt"
- "music-library.rkt"
- "translate.rkt"
- "playlist.rkt"
- "player.rkt"
- "libraries.rkt"
- )
-
-(provide
- (all-from-out racket-webview)
- settings%
- )
-
-(define-runtime-path rkt-gui-dir "gui")
-
-(define library-dlg%
- (class wv-dialog%
- (init-field [kind #f] [result-cb (λ args #f)]
- [id (new-id)] [name ""] [local-path ""]
- [host ""] [prefixes ""])
- (inherit-field settings icon parent)
-
- (super-new
- [html-path "library-dialog.html"]
- [title (tr 'settings-library)]
- [icon (build-path rkt-gui-dir "rktplayer.png")]
- [quit-on-close #f]
- )
-
- (define initialized #f)
- (define btn-ok #f)
- (define btn-cancel #f)
- (define lbl-name #f)
- (define lbl-local-path #f)
- (define btn-browse #f)
- (define lbl-host #f)
- (define lbl-prefixes #f)
- (define inp-local-path #f)
- (define inp-name #f)
- (define inp-host #f)
- (define inp-prefixes #f)
-
- (define/public (set-labels)
- (send btn-ok set-innerHTML! (tr 'ok))
- (send btn-cancel set-innerHTML! (tr 'cancel))
- (send lbl-name set-innerHTML! (tr 'name))
- (send lbl-local-path set-innerHTML! (tr 'local-path))
- (send lbl-host set-innerHTML! (tr 'host))
- (send lbl-prefixes set-innerHTML! (tr 'prefixes))
- (send btn-browse set-innerHTML! (tr 'browse))
- )
-
- (define (get el)
- (let ((str (send el get)))
- (string-trim str)))
-
- (define/public (select-library)
- (let* ((music-library (get inp-local-path))
- (dir (send this choose-dir
- (tr 'choose-lib-folder)
- music-library
- )))
- (displayln "Directory kiezen")
- (if (eq? dir 'showing)
- 'done
- (unless (eq? dir #f)
- (send inp-local-path set! dir))
- )
- )
- )
-
- (define/override (page-loaded oke)
- (unless initialized
- (when oke
- (set! initialized #t)
- (set! btn-ok (send this element 'ok))
- (set! btn-cancel (send this element 'cancel))
- (set! lbl-name (send this element 'lbl-name))
- (set! lbl-local-path (send this element 'lbl-local-path))
- (set! lbl-host (send this element 'lbl-host))
- (set! lbl-prefixes (send this element 'lbl-prefixes))
- (set! inp-name (send this element 'name))
- (set! inp-local-path (send this element 'local-path))
- (set! btn-browse (send this element 'browse))
- (set! inp-host (send this element 'host))
- (set! inp-prefixes (send this element 'prefixes))
-
- (send inp-name set! name)
- (send inp-local-path set! local-path)
- (send inp-host set! host)
- (send inp-prefixes set! prefixes)
-
- (send this set-labels)
-
- (send this bind! 'browse 'click (λ (el evt data)
- (send this select-library)))
-
- (send this bind! 'ok 'click (λ (el evt data)
- (let ((name (get inp-name))
- (local-path (get inp-local-path))
- (host (get inp-host))
- (prefixes (get inp-prefixes)))
- (result-cb id name local-path host prefixes)
- (send this close))))
- (send this bind! 'cancel 'click (λ (el evt data) (send this close)))
- (send this bind! 'dev 'click (λ args (send this devtools)))
- )
- ))
- )
- )
-
-(define settings%
- (class wv-dialog%
- (init-field [log-file #f])
- (inherit-field settings icon parent)
-
- (super-new
- [html-path "settings.html"]
- [title (tr 'settings-title)]
- [icon (build-path rkt-gui-dir "rktplayer.png")]
- [quit-on-close #f]
- )
-
- (define initialized #f)
- (define btn-ok #f)
- (define btn-cancel #f)
- (define btn-add #f)
- (define btn-edit #f)
- (define btn-remove #f)
- (define lbl-language #f)
- (define lbl-name #f)
- (define lbl-local-path #f)
- (define lbl-host #f)
- (define lbl-prefixes #f)
- (define lbl-lib #f)
- (define div-language #f)
- (define sel-language #f)
-
- (define libs (new libraries% [settings settings]))
-
- (define cfg (send settings clone 'settings))
-
- (define/public (set-labels)
- (send btn-ok set-innerHTML! (tr 'ok))
- (send btn-cancel set-innerHTML! (tr 'cancel))
- (send btn-add set-innerHTML! (tr 'library-add))
- (send btn-edit set-innerHTML! (tr 'library-edit))
- (send btn-remove set-innerHTML! (tr 'library-remove))
- (send lbl-language set-innerHTML! (tr 'language))
- (send lbl-name set-innerHTML! (tr 'name))
- (send lbl-local-path set-innerHTML! (tr 'local-path))
- (send lbl-host set-innerHTML! (tr 'host))
- (send lbl-prefixes set-innerHTML! (tr 'prefixes))
- (send lbl-lib set-innerHTML! (tr 'lbl-libary-path))
- )
-
- (define/public (update-libraries)
- (let ((count (send libs count)))
- (letrec ((f (λ (i)
- (if (= i count)
- '()
- (cons
- (let* ((id (send libs library-id i))
- (entry (begin
- (dbg-rktplayer "index = ~a, id = ~a, symbol? id = ~a" i id (symbol? id))
- (send libs get-library id)))
- (name (send entry get-name))
- (local-path (send entry get-local-path))
- (host (send entry get-host))
- (tr-attr (if (send entry is-current?)
- '((class "current"))
- '((class "none"))))
- )
- (list 'tr (append (list (list 'id (format "~a" id)))
- tr-attr)
- (list 'td (list '(class "name")) name)
- (list 'td '((class "path")) local-path)
- (list 'td '((class "host")) host)))
- (f (+ i 1)))))))
- (let* ((tbl (f 0))
- (el (send this element 'lib-body))
- (html (if (= count 0)
- ""
- (apply string-append (map xexpr->string tbl)))))
- (displayln html)
- (send el set-innerHTML! html)
- (send this bind! "table.libraries tr" 'click
- (lambda (el evt data)
- (let* ((new-id (string->symbol (send el attr 'id)))
- (new-lib (send libs get-library new-id))
- (cur-lib (send libs current-library))
- )
- (displayln new-id)
- (displayln new-lib)
- (displayln cur-lib)
- (unless (eq? cur-lib #f)
- (let ((cur-el (send this element (send cur-lib get-id))))
- (send cur-el remove-class! 'current)
- (send cur-lib set-current! #f)))
- (unless (eq? new-id #f)
- (let ((new-el (send this element new-id)))
- (displayln new-el)
- (displayln (send new-el attr 'id))
- (send new-el set-attr! '(test "NEE!"))
- (send new-el add-class! "current")
- (send new-lib set-current! #t)
- (send libs update-library new-lib)))
- )))
- ))))
-
- (define/public (add-library)
- (let* ((cb (λ (id name local-path host prefixes)
- (send libs add-library (new library% [id id]
- [name name] [local-path local-path]
- [host host] [prefixes prefixes] [current #f]))
- (send this update-libraries)))
- (dlg (new library-dlg% [parent this]
- [settings (send settings clone 'library-dlg)]
- [kind 'add] [result-cb cb])))
- (send dlg show)))
-
- (define/override (page-loaded oke)
- (unless initialized
- (when oke
- (set! initialized #t)
- (set! btn-ok (send this element 'ok))
- (set! btn-cancel (send this element 'cancel))
- (set! btn-add (send this element 'add))
- (set! btn-edit (send this element 'edit))
- (set! btn-remove (send this element 'remove))
- (set! lbl-language (send this element 'lbl-language))
- (set! lbl-lib (send this element 'lbl-libary-path))
- (set! lbl-name (send this element 'lbl-name))
- (set! lbl-local-path (send this element 'lbl-local-path))
- (set! lbl-host (send this element 'lbl-host))
- (set! lbl-prefixes (send this element 'lbl-prefixes))
- (set! div-language (send this element 'language))
-
- (send this set-labels)
-
- (send div-language set-innerHTML! (make-select-list 'sel-lang (languages) (current-lang)))
-
- (send this bind! 'sel-lang 'change (λ (el evt data)
- (let ((lang (string->symbol
- (format "~a" (hash-ref data 'value (current-lang))))))
- (set-lang! lang)
- (send cfg set! 'language lang)
- (send this set-labels))))
-
- (send this bind! 'ok 'click (λ (el evt data) (send this close)))
- (send this bind! 'cancel 'click (λ (el evt data) (send this close)))
- (send this bind! 'dev 'click (λ args (send this devtools)))
- (send this bind! 'add 'click (λ (el evt data) (send this add-library)))
- (send this bind! 'edit 'click (λ (el evt data) (send this edit-library)))
- (send this bind! 'remove 'click (λ (el evt data) (send this remove-library)))
-
- (send this update-libraries)
- )
- )
- (info-rktplayer "page loaded")
- )
-
- (begin
- #t)
- )
- )
