220 lines
6.1 KiB
Racket
220 lines
6.1 KiB
Racket
#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])))
|