Initial import of rkt-web-player
This commit is contained in:
@@ -0,0 +1,222 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket-audio
|
||||
racket/file
|
||||
racket/list
|
||||
racket-mimetypes
|
||||
racket/path
|
||||
racket/string)
|
||||
|
||||
(provide (struct-out music-library)
|
||||
(struct-out browser-entry)
|
||||
(struct-out track)
|
||||
make-music-libraries
|
||||
browse-library
|
||||
browser-entry->tracks)
|
||||
|
||||
(struct music-library
|
||||
(id name root)
|
||||
#:transparent)
|
||||
|
||||
(struct browser-entry
|
||||
(name kind relative-path)
|
||||
#:transparent)
|
||||
|
||||
(struct track
|
||||
(file title artist album duration mime-type)
|
||||
#:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define supported-extensions
|
||||
(audio-supported-extensions))
|
||||
|
||||
(define (audio-file? file)
|
||||
(let ((extension (path-get-extension file)))
|
||||
(and extension
|
||||
(member (string-downcase
|
||||
(string-trim
|
||||
(bytes->string/utf-8 extension)
|
||||
"."))
|
||||
supported-extensions)
|
||||
#t)))
|
||||
|
||||
(define (hidden-name? path)
|
||||
(string-prefix? (path->string path) "."))
|
||||
|
||||
(define (file-title file)
|
||||
(let* ((name (file-name-from-path file))
|
||||
(without-extension
|
||||
(if name
|
||||
(path-replace-extension name #"")
|
||||
file)))
|
||||
(path->string without-extension)))
|
||||
|
||||
(define (nonempty value fallback)
|
||||
(if (and (string? value)
|
||||
(not (string=? (string-trim value) "")))
|
||||
value
|
||||
fallback))
|
||||
|
||||
(define (path->track file)
|
||||
(let ((fallback-title (file-title file)))
|
||||
(with-handlers
|
||||
((exn:fail?
|
||||
(λ (_)
|
||||
(track file fallback-title "" "" #f
|
||||
(mimetype-for-ext file)))))
|
||||
(call-with-id3-tags
|
||||
file
|
||||
(λ (tags)
|
||||
(if (tags-valid? tags)
|
||||
(track file
|
||||
(nonempty (tags-title tags) fallback-title)
|
||||
(nonempty (tags-artist tags) "")
|
||||
(nonempty (tags-album tags) "")
|
||||
(let ((length (tags-length tags)))
|
||||
(if (and (number? length) (positive? length))
|
||||
length
|
||||
#f))
|
||||
(mimetype-for-ext file))
|
||||
(track file fallback-title "" "" #f
|
||||
(mimetype-for-ext file))))))))
|
||||
|
||||
(define (library-path library relative-path)
|
||||
(if (null? relative-path)
|
||||
(music-library-root library)
|
||||
(apply build-path
|
||||
(music-library-root library)
|
||||
relative-path)))
|
||||
|
||||
(define (path-kind path)
|
||||
(cond
|
||||
((directory-exists? path) 'container)
|
||||
((and (file-exists? path)
|
||||
(audio-file? path))
|
||||
'track)
|
||||
(else #f)))
|
||||
|
||||
(define (entry<? first second)
|
||||
(cond
|
||||
((and (eq? (browser-entry-kind first) 'container)
|
||||
(eq? (browser-entry-kind second) 'track))
|
||||
#t)
|
||||
((and (eq? (browser-entry-kind first) 'track)
|
||||
(eq? (browser-entry-kind second) 'container))
|
||||
#f)
|
||||
(else
|
||||
(string-ci<? (browser-entry-name first)
|
||||
(browser-entry-name second)))))
|
||||
|
||||
(define (directory-tracks library relative-path)
|
||||
(append-map
|
||||
(λ (entry)
|
||||
(if (eq? (browser-entry-kind entry) 'container)
|
||||
(directory-tracks library
|
||||
(browser-entry-relative-path entry))
|
||||
(list
|
||||
(path->track
|
||||
(library-path library
|
||||
(browser-entry-relative-path entry))))))
|
||||
(browse-library library relative-path)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Turn configured directory paths into music libraries.
|
||||
; pre : Every value is a path-string naming an existing directory.
|
||||
; post : No directory contents or audio metadata have been read.
|
||||
; result : Libraries in configuration order, without duplicate roots.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (make-music-libraries paths)
|
||||
(let ((roots
|
||||
(remove-duplicates
|
||||
(map (λ (path)
|
||||
(normal-case-path
|
||||
(path->complete-path path)))
|
||||
paths)
|
||||
equal?)))
|
||||
(for/list ((root (in-list roots))
|
||||
(index (in-naturals)))
|
||||
(unless (directory-exists? root)
|
||||
(raise-arguments-error
|
||||
'make-music-libraries
|
||||
"music library is not an existing directory"
|
||||
"path" root))
|
||||
(let ((name (file-name-from-path root)))
|
||||
(music-library
|
||||
(format "library-~a" index)
|
||||
(if name
|
||||
(path->string name)
|
||||
(path->string root))
|
||||
root)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : List the immediate folders and supported audio files in a library.
|
||||
; pre : Relative-path was produced by a previous browse result.
|
||||
; post : Child directories are listed before tracks; metadata is not read.
|
||||
; result : Browser entries for one directory level.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (browse-library library relative-path)
|
||||
(let ((path (library-path library relative-path)))
|
||||
(unless (directory-exists? path)
|
||||
(raise-arguments-error
|
||||
'browse-library
|
||||
"library directory does not exist"
|
||||
"path" path))
|
||||
(sort
|
||||
(filter-map
|
||||
(λ (name)
|
||||
(let* ((full-path (build-path path name))
|
||||
(kind (path-kind full-path)))
|
||||
(and kind
|
||||
(not (and (eq? kind 'container)
|
||||
(hidden-name? name)))
|
||||
(browser-entry
|
||||
(path->string name)
|
||||
kind
|
||||
(append relative-path (list name))))))
|
||||
(directory-list path))
|
||||
entry<?)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve a selected browser entry to playable tracks.
|
||||
; pre : Entry belongs to library and was produced by browse-library.
|
||||
; post : Track metadata is read; containers are traversed recursively.
|
||||
; result : One track, or all supported tracks below the selected container.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (browser-entry->tracks library entry)
|
||||
(if (eq? (browser-entry-kind entry) 'container)
|
||||
(directory-tracks library
|
||||
(browser-entry-relative-path entry))
|
||||
(list
|
||||
(path->track
|
||||
(library-path library
|
||||
(browser-entry-relative-path entry))))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define root
|
||||
(make-temporary-file "rkt-web-library-~a" 'directory))
|
||||
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(make-directory (build-path root "Album"))
|
||||
(call-with-output-file (build-path root "track.mp3") void)
|
||||
(call-with-output-file (build-path root "cover.jpg") void)
|
||||
(let* ((libraries (make-music-libraries (list root)))
|
||||
(entries (browse-library (car libraries) '())))
|
||||
(check-equal? (length libraries) 1)
|
||||
(check-equal? (length entries) 2)
|
||||
(check-equal? (browser-entry-name (car entries)) "Album")
|
||||
(check-eq? (browser-entry-kind (car entries)) 'container)
|
||||
(check-equal? (browser-entry-name (cadr entries)) "track.mp3")
|
||||
(check-eq? (browser-entry-kind (cadr entries)) 'track)))
|
||||
(λ ()
|
||||
(delete-directory/files root))))
|
||||
+1037
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,92 @@
|
||||
#lang racket/base
|
||||
|
||||
(require json
|
||||
racket/contract
|
||||
racket/runtime-path
|
||||
web-server/dispatch
|
||||
web-server/http
|
||||
web-server/http/json
|
||||
web-server/servlet-env
|
||||
"player.rkt")
|
||||
|
||||
(provide serve-player)
|
||||
|
||||
(define-runtime-path public-directory "../public")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; HTTP handlers
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define current-player #f)
|
||||
|
||||
(define (json-response value #:code [code 200])
|
||||
(response/jsexpr
|
||||
value
|
||||
#:code code
|
||||
#:headers (list (header #"Cache-Control" #"no-store"))))
|
||||
|
||||
(define (error-response exception)
|
||||
(json-response
|
||||
(hasheq 'error (exn-message exception))
|
||||
#:code 400))
|
||||
|
||||
(define (request-jsexpr request)
|
||||
(let ((body (request-post-data/raw request)))
|
||||
(if (and body (positive? (bytes-length body)))
|
||||
(bytes->jsexpr body)
|
||||
(hasheq))))
|
||||
|
||||
(define (state-handler _request)
|
||||
(json-response (player-state->jsexpr current-player)))
|
||||
|
||||
(define (discover-handler _request)
|
||||
(player-discover! current-player)
|
||||
(json-response (player-state->jsexpr current-player)))
|
||||
|
||||
(define (command-handler request command)
|
||||
(with-handlers
|
||||
((exn:fail? error-response))
|
||||
(json-response
|
||||
(player-command!
|
||||
current-player
|
||||
command
|
||||
(request-jsexpr request)))))
|
||||
|
||||
(define-values (dispatch _url)
|
||||
(dispatch-rules
|
||||
[("api" "state") #:method "get" state-handler]
|
||||
[("api" "discover") #:method "post" discover-handler]
|
||||
[("api" "command" (string-arg))
|
||||
#:method "post"
|
||||
command-handler]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Serve the web interface and JSON player API.
|
||||
; pre : Value is a player, listen-ip is a string, and port is valid.
|
||||
; post : Static files and API routes are served until the server stops.
|
||||
; result : The result returned by serve/servlet.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define/contract (serve-player value
|
||||
#:listen-ip [listen-ip "127.0.0.1"]
|
||||
#:port [port 8080]
|
||||
#:launch-browser? [launch-browser? #t])
|
||||
(->* (any/c)
|
||||
(#:listen-ip string?
|
||||
#:port exact-positive-integer?
|
||||
#:launch-browser? boolean?)
|
||||
any)
|
||||
(set! current-player value)
|
||||
(serve/servlet
|
||||
dispatch
|
||||
#:listen-ip listen-ip
|
||||
#:port port
|
||||
#:connection-close? #t
|
||||
#:launch-browser? launch-browser?
|
||||
#:quit? #f
|
||||
#:banner? #t
|
||||
#:servlet-regexp #rx"^/api(?:/|$)"
|
||||
#:extra-files-paths (list public-directory)))
|
||||
Reference in New Issue
Block a user