Complete refactoring for rktplayer, in order to make it play on DLNA renderers and also use UpNP media server resources.
This commit is contained in:
@@ -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])))
|
||||
Reference in New Issue
Block a user