Better renderer and server support and higher level functions. Seek solutions.
This commit is contained in:
@@ -0,0 +1,200 @@
|
||||
#lang racket/base
|
||||
|
||||
;; Resolve DLNA resource capabilities advertised by an HTTP media server.
|
||||
|
||||
(require net/http-client
|
||||
net/url
|
||||
racket/match
|
||||
racket/port
|
||||
racket/string
|
||||
simple-log)
|
||||
|
||||
(provide resolve-dlna-resource-protocol-info
|
||||
clear-dlna-resource-capability-cache!)
|
||||
|
||||
(sl-def-log upnp-resource)
|
||||
|
||||
(define capability-cache (make-hash))
|
||||
(define capability-cache-lock (make-semaphore 1))
|
||||
|
||||
(define (clear-dlna-resource-capability-cache!)
|
||||
(call-with-semaphore
|
||||
capability-cache-lock
|
||||
(lambda () (hash-clear! capability-cache))))
|
||||
|
||||
(define (url-request-target value)
|
||||
(let* ([relative
|
||||
(struct-copy url value
|
||||
[scheme #f]
|
||||
[user #f]
|
||||
[host #f]
|
||||
[port #f]
|
||||
[fragment #f])]
|
||||
[target (url->string relative)])
|
||||
(if (string=? target "") "/" target)))
|
||||
|
||||
(define (header-value headers name)
|
||||
(for/or ([header (in-list headers)])
|
||||
(let* ([text
|
||||
(if (bytes? header)
|
||||
(bytes->string/latin-1 header)
|
||||
header)]
|
||||
[match
|
||||
(and (string? text)
|
||||
(regexp-match
|
||||
#px"^([^:]+):[ \t]*(.*?)[ \t]*$"
|
||||
text))])
|
||||
(and match
|
||||
(string-ci=? (cadr match) name)
|
||||
(caddr match)))))
|
||||
|
||||
(define (protocol-info-parts protocol-info)
|
||||
(and protocol-info
|
||||
(regexp-match #px"^([^:]*):([^:]*):([^:]*):(.*)$"
|
||||
protocol-info)))
|
||||
|
||||
(define (protocol-info-additional-info protocol-info)
|
||||
(let ([parts (protocol-info-parts protocol-info)])
|
||||
(and parts (list-ref parts 4))))
|
||||
|
||||
(define (replace-additional-info protocol-info additional-info)
|
||||
(match (protocol-info-parts protocol-info)
|
||||
[(list _ protocol network content-type _)
|
||||
(string-join
|
||||
(list protocol network content-type additional-info)
|
||||
":")]
|
||||
[_ protocol-info]))
|
||||
|
||||
(define (call-with-timeout seconds thunk)
|
||||
(let ([custodian (make-custodian)]
|
||||
[result-channel (make-channel)])
|
||||
(parameterize ([current-custodian custodian])
|
||||
(thread
|
||||
(lambda ()
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exception)
|
||||
(channel-put result-channel
|
||||
(cons #f exception)))])
|
||||
(channel-put result-channel
|
||||
(cons #t (thunk)))))))
|
||||
(let ([result (sync/timeout seconds result-channel)])
|
||||
(custodian-shutdown-all custodian)
|
||||
(cond
|
||||
[(not result)
|
||||
(error 'resolve-dlna-resource-protocol-info
|
||||
"HTTP capability request timed out")]
|
||||
[(car result) (cdr result)]
|
||||
[else (raise (cdr result))]))))
|
||||
|
||||
(define (request-content-features uri timeout)
|
||||
(let* ([url-value (string->url uri)]
|
||||
[scheme (or (url-scheme url-value) "http")]
|
||||
[ssl? (string-ci=? scheme "https")]
|
||||
[host (url-host url-value)]
|
||||
[port (or (url-port url-value) (if ssl? 443 80))])
|
||||
(unless (and host
|
||||
(or (string-ci=? scheme "http")
|
||||
(string-ci=? scheme "https")))
|
||||
(raise-arguments-error
|
||||
'resolve-dlna-resource-protocol-info
|
||||
"resource is not an HTTP URI"
|
||||
"uri" uri))
|
||||
(call-with-timeout
|
||||
timeout
|
||||
(lambda ()
|
||||
(let-values ([(status headers in)
|
||||
(http-sendrecv
|
||||
host
|
||||
(url-request-target url-value)
|
||||
#:ssl? ssl?
|
||||
#:port port
|
||||
#:method #"HEAD"
|
||||
#:headers
|
||||
(list "getcontentFeatures.dlna.org: 1"
|
||||
"transferMode.dlna.org: Streaming"
|
||||
"Connection: close"))])
|
||||
(void status)
|
||||
(close-input-port in)
|
||||
(header-value headers "contentFeatures.dlna.org"))))))
|
||||
|
||||
(define (base-protocol-info protocol-info mime-type)
|
||||
(cond
|
||||
[(and (string? protocol-info)
|
||||
(not (string=? (string-trim protocol-info) "")))
|
||||
protocol-info]
|
||||
[(and (string? mime-type)
|
||||
(not (string=? (string-trim mime-type) "")))
|
||||
(format "http-get:*:~a:*" mime-type)]
|
||||
[else "http-get:*:application/octet-stream:*"]))
|
||||
|
||||
(define (resolve-dlna-resource-protocol-info
|
||||
uri
|
||||
#:protocol-info [protocol-info #f]
|
||||
#:mime-type [mime-type #f]
|
||||
#:timeout [timeout 5.0])
|
||||
(unless (and (string? uri)
|
||||
(not (string=? (string-trim uri) "")))
|
||||
(raise-argument-error
|
||||
'resolve-dlna-resource-protocol-info
|
||||
"non-empty-string?"
|
||||
uri))
|
||||
(for ([value (in-list (list protocol-info mime-type))])
|
||||
(unless (or (not value) (string? value))
|
||||
(raise-argument-error
|
||||
'resolve-dlna-resource-protocol-info
|
||||
"(or/c #f string?)"
|
||||
value)))
|
||||
(unless (and (rational? timeout) (positive? timeout))
|
||||
(raise-argument-error
|
||||
'resolve-dlna-resource-protocol-info
|
||||
"positive-real?"
|
||||
timeout))
|
||||
(let* ([base (base-protocol-info protocol-info mime-type)]
|
||||
[additional-info (protocol-info-additional-info base)])
|
||||
(cond
|
||||
[(and additional-info
|
||||
(not (string=? additional-info "*")))
|
||||
base]
|
||||
[else
|
||||
(let* ([key (list uri base)]
|
||||
[cached
|
||||
(call-with-semaphore
|
||||
capability-cache-lock
|
||||
(lambda () (hash-ref capability-cache key #f)))])
|
||||
(or cached
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exception)
|
||||
(warn-upnp-resource
|
||||
"Could not resolve DLNA capabilities for ~a: ~a"
|
||||
uri
|
||||
(exn-message exception))
|
||||
base)])
|
||||
(let ([content-features
|
||||
(request-content-features uri timeout)])
|
||||
(if (and content-features
|
||||
(not (string=? content-features "")))
|
||||
(let ([resolved
|
||||
(replace-additional-info
|
||||
base
|
||||
content-features)])
|
||||
(dbg-upnp-resource
|
||||
"Resolved DLNA protocolInfo for ~a: ~a"
|
||||
uri
|
||||
resolved)
|
||||
(call-with-semaphore
|
||||
capability-cache-lock
|
||||
(lambda ()
|
||||
(hash-set! capability-cache key resolved)))
|
||||
resolved)
|
||||
base)))))])))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(check-equal?
|
||||
(replace-additional-info
|
||||
"http-get:*:audio/flac:*"
|
||||
"DLNA.ORG_OP=01;DLNA.ORG_CI=0")
|
||||
"http-get:*:audio/flac:DLNA.ORG_OP=01;DLNA.ORG_CI=0"))
|
||||
Reference in New Issue
Block a user