359 lines
12 KiB
Racket
359 lines
12 KiB
Racket
#lang racket/base
|
|
|
|
;; Publish local media files through Racket's web server.
|
|
;;
|
|
;; The module maps explicit URLs to local files. Racket's file dispatcher
|
|
;; performs the actual streaming and supplies HEAD and HTTP byte-range support,
|
|
;; which media renderers commonly use for probing and seeking.
|
|
|
|
(require net/url
|
|
racket/async-channel
|
|
racket/file
|
|
racket/path
|
|
racket/string
|
|
(prefix-in files: web-server/dispatchers/dispatch-files)
|
|
(prefix-in sequence: web-server/dispatchers/dispatch-sequencer)
|
|
web-server/http
|
|
web-server/servlet-dispatch
|
|
web-server/web-server
|
|
racket-mimetypes
|
|
"didl-lite.rkt")
|
|
|
|
(provide start-media-file-server
|
|
media-file-server?
|
|
media-file-server-url
|
|
media-file-server-publish!
|
|
media-file-server-didl-lite
|
|
media-file-server-unpublish!
|
|
media-file-server-stop!)
|
|
|
|
(define dlna-byte-range-features
|
|
"DLNA.ORG_OP=01;DLNA.ORG_CI=0")
|
|
|
|
(struct media-file-server
|
|
(base-url
|
|
base-path
|
|
publications
|
|
mime-types
|
|
lock
|
|
stop
|
|
[stopped? #:mutable])
|
|
#:constructor-name make-media-file-server)
|
|
|
|
(define (check-media-file-server who value)
|
|
(unless (media-file-server? value)
|
|
(raise-argument-error who "media-file-server?" value)))
|
|
|
|
(define (url-effective-port value)
|
|
(or (url-port value)
|
|
(and (equal? (url-scheme value) "http") 80)))
|
|
|
|
(define (url-path-string value)
|
|
(let ([path
|
|
(string-join
|
|
(for/list ([part (in-list (url-path value))])
|
|
(path/param-path part))
|
|
"/")])
|
|
(string-append
|
|
(if (url-path-absolute? value) "/" "")
|
|
path)))
|
|
|
|
(define (url-has-query? value)
|
|
(and (url-query value)
|
|
(pair? (url-query value))))
|
|
|
|
(define (normalize-base-url who value)
|
|
(unless (string? value)
|
|
(raise-argument-error who "string?" value))
|
|
(let ([parsed (string->url value)])
|
|
(unless (and (equal? (url-scheme parsed) "http")
|
|
(url-host parsed)
|
|
(url-effective-port parsed))
|
|
(raise-arguments-error
|
|
who
|
|
"expected an absolute HTTP URL"
|
|
"url" value))
|
|
(when (or (url-user parsed)
|
|
(url-has-query? parsed)
|
|
(url-fragment parsed))
|
|
(raise-arguments-error
|
|
who
|
|
"the server URL may not contain credentials, a query, or a fragment"
|
|
"url" value))
|
|
(let* ([text (url->string parsed)]
|
|
[normalized-text
|
|
(if (string-suffix? text "/")
|
|
text
|
|
(string-append text "/"))]
|
|
[normalized (string->url normalized-text)])
|
|
(values normalized
|
|
(url-path-string normalized)))))
|
|
|
|
(define (same-origin? first second)
|
|
(and (equal? (url-scheme first) (url-scheme second))
|
|
(string-ci=? (url-host first) (url-host second))
|
|
(= (url-effective-port first)
|
|
(url-effective-port second))))
|
|
|
|
(define (guess-mime-type path)
|
|
(string->bytes/utf-8
|
|
(mimetype-for-ext path #:default "application/octet-stream")))
|
|
|
|
(define (normalize-mime-type who value path)
|
|
(cond
|
|
[(not value) (guess-mime-type path)]
|
|
[(bytes? value) value]
|
|
[(string? value) (string->bytes/utf-8 value)]
|
|
[else
|
|
(raise-argument-error
|
|
who
|
|
"(or/c #f bytes? string?)"
|
|
value)]))
|
|
|
|
(define (media-file-server-url server)
|
|
(check-media-file-server 'media-file-server-url server)
|
|
(url->string (media-file-server-base-url server)))
|
|
|
|
(define (resolve-publication-url who server value)
|
|
(unless (string? value)
|
|
(raise-argument-error who "string?" value))
|
|
(let* ([base (media-file-server-base-url server)]
|
|
[candidate
|
|
(let ([parsed (string->url value)])
|
|
(if (url-scheme parsed)
|
|
parsed
|
|
(combine-url/relative base value)))])
|
|
(unless (and (equal? (url-scheme candidate) "http")
|
|
(url-host candidate)
|
|
(same-origin? base candidate))
|
|
(raise-arguments-error
|
|
who
|
|
"the publication URL must use the server's HTTP origin"
|
|
"server URL" (url->string base)
|
|
"publication URL" value))
|
|
(when (or (url-user candidate)
|
|
(url-has-query? candidate)
|
|
(url-fragment candidate))
|
|
(raise-arguments-error
|
|
who
|
|
"the publication URL may not contain credentials, a query, or a fragment"
|
|
"publication URL" value))
|
|
(let ([path (url-path-string candidate)])
|
|
(unless (string-prefix? path (media-file-server-base-path server))
|
|
(raise-arguments-error
|
|
who
|
|
"the publication URL must be below the server URL"
|
|
"server URL" (url->string base)
|
|
"publication URL" value))
|
|
(values candidate path))))
|
|
|
|
(define (start-media-file-server url
|
|
#:listen-ip [listen-ip #f])
|
|
(unless (or (not listen-ip) (string? listen-ip))
|
|
(raise-argument-error
|
|
'start-media-file-server
|
|
"(or/c #f string?)"
|
|
listen-ip))
|
|
(let-values ([(base-url base-path)
|
|
(normalize-base-url 'start-media-file-server url)])
|
|
(let* ([publications (make-hash)]
|
|
[mime-types (make-hash)]
|
|
[lock (make-semaphore 1)]
|
|
[missing-path
|
|
(build-path
|
|
(find-system-path 'temp-dir)
|
|
(format "racket-upnp-missing-~a" (gensym)))]
|
|
[url->path
|
|
(lambda (request-url)
|
|
(let ([path
|
|
(call-with-semaphore
|
|
lock
|
|
(lambda ()
|
|
(hash-ref publications
|
|
(url-path-string request-url)
|
|
missing-path)))])
|
|
(values path '())))]
|
|
[path->mime-type
|
|
(lambda (path)
|
|
(call-with-semaphore
|
|
lock
|
|
(lambda ()
|
|
(hash-ref mime-types
|
|
path
|
|
(lambda ()
|
|
(guess-mime-type path))))))]
|
|
[file-dispatcher
|
|
(files:make
|
|
#:url->path url->path
|
|
#:path->mime-type path->mime-type
|
|
#:path->headers dlna-response-headers)]
|
|
[not-found-dispatcher
|
|
(dispatch/servlet
|
|
(lambda (_request)
|
|
(response/full
|
|
404
|
|
#f
|
|
(current-seconds)
|
|
#"text/plain; charset=utf-8"
|
|
'()
|
|
(list #"Not found\n"))))]
|
|
[dispatcher
|
|
(sequence:make
|
|
file-dispatcher
|
|
not-found-dispatcher)]
|
|
[confirmation (make-async-channel)]
|
|
[stop
|
|
(serve
|
|
#:dispatch dispatcher
|
|
#:confirmation-channel confirmation
|
|
#:listen-ip listen-ip
|
|
#:port (url-effective-port base-url))]
|
|
[result (sync confirmation)])
|
|
(when (exn? result)
|
|
(stop)
|
|
(raise result))
|
|
(make-media-file-server
|
|
base-url
|
|
base-path
|
|
publications
|
|
mime-types
|
|
lock
|
|
stop
|
|
#f))))
|
|
|
|
|
|
(define (dlna-response-headers _path)
|
|
(list
|
|
(header #"Accept-Ranges" #"bytes")
|
|
(header #"contentFeatures.dlna.org"
|
|
(string->bytes/utf-8 dlna-byte-range-features))))
|
|
|
|
|
|
(define (media-file-server-publish! server file url
|
|
#:mime-type [mime-type #f])
|
|
(check-media-file-server 'media-file-server-publish! server)
|
|
(unless (path-string? file)
|
|
(raise-argument-error
|
|
'media-file-server-publish!
|
|
"path-string?"
|
|
file))
|
|
(let ([path (path->complete-path file)])
|
|
(unless (file-exists? path)
|
|
(raise-arguments-error
|
|
'media-file-server-publish!
|
|
"media file does not exist"
|
|
"file" file))
|
|
(let-values ([(publication-url publication-path)
|
|
(resolve-publication-url
|
|
'media-file-server-publish!
|
|
server
|
|
url)])
|
|
(call-with-semaphore
|
|
(media-file-server-lock server)
|
|
(lambda ()
|
|
(when (media-file-server-stopped? server)
|
|
(raise-arguments-error
|
|
'media-file-server-publish!
|
|
"media file server has been stopped"
|
|
"server URL" (media-file-server-url server)))
|
|
(hash-set! (media-file-server-publications server)
|
|
publication-path
|
|
path)
|
|
(hash-set! (media-file-server-mime-types server)
|
|
path
|
|
(normalize-mime-type
|
|
'media-file-server-publish!
|
|
mime-type
|
|
path))))
|
|
(url->string publication-url))))
|
|
|
|
(define (media-file-server-didl-lite server url
|
|
#:title [title #f]
|
|
#:artist [artist #f]
|
|
#:album [album #f]
|
|
#:genre [genre #f]
|
|
#:year [year #f]
|
|
#:track [track #f]
|
|
#:duration [duration #f]
|
|
#:id [id "0"]
|
|
#:parent-id [parent-id "0"])
|
|
(check-media-file-server 'media-file-server-didl-lite server)
|
|
(unless (or (not title) (string? title))
|
|
(raise-argument-error
|
|
'media-file-server-didl-lite
|
|
"(or/c #f string?)"
|
|
title))
|
|
(let-values ([(publication-url publication-path)
|
|
(resolve-publication-url
|
|
'media-file-server-didl-lite
|
|
server
|
|
url)])
|
|
(let-values ([(path mime-type)
|
|
(call-with-semaphore
|
|
(media-file-server-lock server)
|
|
(lambda ()
|
|
(let ([path
|
|
(hash-ref
|
|
(media-file-server-publications server)
|
|
publication-path
|
|
#f)])
|
|
(unless path
|
|
(raise-arguments-error
|
|
'media-file-server-didl-lite
|
|
"URL is not published by this media file server"
|
|
"url" url))
|
|
(values
|
|
path
|
|
(hash-ref
|
|
(media-file-server-mime-types server)
|
|
path
|
|
(lambda () (guess-mime-type path)))))))])
|
|
(didl-lite-audio-item
|
|
(url->string publication-url)
|
|
#:protocol-info
|
|
(format "http-get:*:~a:~a"
|
|
(bytes->string/utf-8 mime-type)
|
|
dlna-byte-range-features)
|
|
#:title
|
|
(or title
|
|
(path->string (file-name-from-path path)))
|
|
#:artist artist
|
|
#:album album
|
|
#:genre genre
|
|
#:year year
|
|
#:track track
|
|
#:duration duration
|
|
#:size (file-size path)
|
|
#:id id
|
|
#:parent-id parent-id))))
|
|
|
|
(define (media-file-server-unpublish! server url)
|
|
(check-media-file-server 'media-file-server-unpublish! server)
|
|
(let-values ([(_publication-url publication-path)
|
|
(resolve-publication-url
|
|
'media-file-server-unpublish!
|
|
server
|
|
url)])
|
|
(call-with-semaphore
|
|
(media-file-server-lock server)
|
|
(lambda ()
|
|
(hash-remove! (media-file-server-publications server)
|
|
publication-path)))
|
|
(void)))
|
|
|
|
(define (media-file-server-stop! server)
|
|
(check-media-file-server 'media-file-server-stop! server)
|
|
(let ([stop
|
|
(call-with-semaphore
|
|
(media-file-server-lock server)
|
|
(lambda ()
|
|
(if (media-file-server-stopped? server)
|
|
#f
|
|
(begin
|
|
(set-media-file-server-stopped?! server #t)
|
|
(hash-clear! (media-file-server-publications server))
|
|
(media-file-server-stop server)))))])
|
|
(when stop
|
|
(stop))
|
|
(void)))
|