304 lines
10 KiB
Racket
304 lines
10 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)
|
|
|
|
(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)))
|