media-file-server
This commit is contained in:
@@ -0,0 +1,303 @@
|
||||
#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)
|
||||
|
||||
(provide start-media-file-server
|
||||
media-file-server?
|
||||
media-file-server-url
|
||||
media-file-server-publish!
|
||||
media-file-server-unpublish!
|
||||
media-file-server-stop!)
|
||||
|
||||
(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)
|
||||
(let ([name (string-downcase (path->string path))])
|
||||
(cond
|
||||
[(regexp-match? #rx"[.]flac$" name) #"audio/flac"]
|
||||
[(regexp-match? #rx"[.]opus$" name) #"audio/ogg"]
|
||||
[(regexp-match? #rx"[.]ogg$" name) #"audio/ogg"]
|
||||
[(regexp-match? #rx"[.]oga$" name) #"audio/ogg"]
|
||||
[(regexp-match? #rx"[.]mp3$" name) #"audio/mpeg"]
|
||||
[(regexp-match? #rx"[.]m4a$" name) #"audio/mp4"]
|
||||
[(regexp-match? #rx"[.]mp4$" name) #"video/mp4"]
|
||||
[(regexp-match? #rx"[.]aac$" name) #"audio/aac"]
|
||||
[(regexp-match? #rx"[.]wav$" name) #"audio/wav"]
|
||||
[(regexp-match? #rx"[.]wave$" name) #"audio/wav"]
|
||||
[(regexp-match? #rx"[.]aif$" name) #"audio/aiff"]
|
||||
[(regexp-match? #rx"[.]aiff$" name) #"audio/aiff"]
|
||||
[(regexp-match? #rx"[.]ape$" name) #"audio/x-ape"]
|
||||
[(regexp-match? #rx"[.]wv$" name) #"audio/wavpack"]
|
||||
[(regexp-match? #rx"[.]mkv$" name) #"video/x-matroska"]
|
||||
[(regexp-match? #rx"[.]webm$" name) #"video/webm"]
|
||||
[(regexp-match? #rx"[.]jpg$" name) #"image/jpeg"]
|
||||
[(regexp-match? #rx"[.]jpeg$" name) #"image/jpeg"]
|
||||
[(regexp-match? #rx"[.]png$" name) #"image/png"]
|
||||
[else #"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)]
|
||||
[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 (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-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)))
|
||||
@@ -7,6 +7,7 @@
|
||||
@include-section["main.scrbl"]
|
||||
@include-section["media-renderer.scrbl"]
|
||||
@include-section["media-server.scrbl"]
|
||||
@include-section["media-file-server.scrbl"]
|
||||
@include-section["av-transport.scrbl"]
|
||||
@include-section["rendering-control.scrbl"]
|
||||
@include-section["connection-manager.scrbl"]
|
||||
|
||||
Reference in New Issue
Block a user