hans/rkt-web-player
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactoring

Browse Source
This commit is contained in:
Hans Dijkema
2026-09-01 09:31:49 +02:00
parent b3a5a0b345
commit a5a53b7efc
20 changed files with 2082 additions and 1032 deletions
Download Patch File Download Diff File Expand all files Collapse all files
private/library.rkt
+234 -105
View File
@@ -45,19 +45,25 @@
"folder.jpg" "folder.jpeg" "folder.png"
"front.jpg" "front.jpeg" "front.png"))
;;; Checks whether a path has an extension supported by racket-audio.
(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)))
(if (eq? extension #f)
#f
(let ((extension-name
(string-downcase
(string-trim
(bytes->string/utf-8 extension)
"."))))
(if (member extension-name supported-extensions)
#t
#f)))))
;;; Checks whether the final path element starts with a dot.
(define (hidden-name? path)
(string-prefix? (path->string path) "."))
;;; Derives a fallback track title from the file name without its extension.
(define (file-title file)
(let* ((name (file-name-from-path file))
(without-extension
@@ -66,12 +72,15 @@
file)))
(path->string without-extension)))
;;; Returns a non-empty string value or the supplied fallback.
(define (nonempty value fallback)
(if (and (string? value)
(not (string=? (string-trim value) "")))
value
fallback))
;;; Reads audio metadata and converts a file path to a track value.
;;; File-name and MIME-type fallbacks are used when metadata cannot be read.
(define (path->track file)
(let ((fallback-title (file-title file)))
(with-handlers
@@ -95,6 +104,7 @@
(track file fallback-title "" "" #f
(mimetype-for-ext file))))))))
;;; Builds the filesystem path represented by a library-relative path.
(define (library-path library relative-path)
(if (null? relative-path)
(music-library-root library)
@@ -102,6 +112,7 @@
(music-library-root library)
relative-path)))
;;; Classifies a path as a container, supported track or unusable entry.
(define (path-kind path)
(cond
((directory-exists? path) 'container)
@@ -110,6 +121,7 @@
'track)
(else #f)))
;;; Orders browser entries with containers first and names alphabetically.
(define (entry<? first second)
(cond
((and (eq? (browser-entry-kind first) 'container)
@@ -122,6 +134,7 @@
(string-ci<? (browser-entry-name first)
(browser-entry-name second)))))
;;; Recursively converts the browsable contents of a directory to tracks.
(define (directory-tracks library relative-path)
(append-map
(λ (entry)
@@ -134,126 +147,196 @@
(browser-entry-relative-path entry))))))
(browse-library library relative-path)))
(define (library-contains-audio-file? libraries file)
(and (path-string? file)
(file-exists? file)
(audio-file? file)
(let ((full-file
(with-handlers ((exn:fail? (λ (_) #f)))
(simplify-path (path->complete-path file) #t))))
(and full-file
(for/or ((library (in-list libraries)))
(define root
(with-handlers ((exn:fail? (λ (_) #f)))
(simplify-path
(path->complete-path (music-library-root library))
#t)))
(and root
(let ((relative (find-relative-path root full-file)))
(and (relative-path? relative)
(not (member 'up (explode-path relative)))))))))))
;;; Produces a resolved complete path, or #f when resolution fails.
(define (complete-path/safe path)
(with-handlers ((exn:fail? (λ (_) #f)))
(simplify-path (path->complete-path path) #t)))
;;; Checks whether file is located below root without traversing upward.
(define (path-below-root? root file)
(let* ((relative (find-relative-path root file))
(elements (explode-path relative)))
(and (relative-path? relative)
(not (member 'up elements)))))
;;; Recognizes a library specification containing a display name and path.
(define (named-library-specification? specification)
(and (list? specification)
(= (length specification) 2)
(string? (car specification))
(path-string? (cadr specification))))
;;; Extracts the optional display name and path from a library specification.
(define (specification-values specification)
(cond
((named-library-specification? specification)
(values (string-trim (car specification))
(cadr specification)))
((path-string? specification)
(values #f specification))
(else
(raise-argument-error
'make-music-libraries
"(or/c path-string? (list/c string? path-string?))"
specification))))
;;; Reads embedded ID3 artwork from a track, returning #f when unavailable.
(define (embedded-artwork item)
(with-handlers ((exn:fail? (λ (_) #f)))
(call-with-id3-tags
(track-file item)
(λ (tags)
(if (not (tags-valid? tags))
#f
(let ((picture (tags-picture tags)))
(if (eq? picture #f)
#f
(let ((mime (id3-picture-mimetype picture)))
(artwork
(if (and (string? mime)
(not (string=? mime "")))
mime
"application/octet-stream")
(id3-picture-bytes picture))))))))))
;;; Checks whether a path names an existing conventional cover image.
(define (cover-file? candidate)
(let ((name (file-name-from-path candidate)))
(cond
((eq? name #f) #f)
((not (file-exists? candidate)) #f)
((member (path->string name)
cover-file-names
string-ci=?) #t)
(else #f))))
;;; Searches the track directory for a conventional cover image.
(define (cover-artwork item)
(with-handlers ((exn:fail? (λ (_) #f)))
(let* ((track-directory (path-only (track-file item)))
(directory (if (eq? track-directory #f)
(current-directory)
track-directory))
(cover (findf cover-file?
(directory-list directory #:build? #t))))
(if (eq? cover #f)
#f
(let ((mime (mimetype-for-ext cover)))
(artwork (if (string? mime)
mime
"application/octet-stream")
(file->bytes cover)))))))
;;; Validates one normalized library root and constructs its public value.
(define (named-root->music-library named-root index)
(let ((configured-name (car named-root))
(root (cadr named-root)))
(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))
(default-name (if (eq? name #f)
(path->string root)
(path->string name))))
(music-library
(format "library-~a" index)
(cond
((eq? configured-name #f) default-name)
((string=? configured-name "") default-name)
(else configured-name))
root))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check whether a supported audio file belongs to a music library.
; pre : Libraries contains music-library values; file may be any value.
; post : The file system remains unchanged.
; result : #t when file exists below a configured root, otherwise #f.
; internals: audio-file? first rejects unsupported files. complete-path/safe
; resolves the candidate and each library root. The named loop calls
; path-below-root? until one root contains the file; that helper uses
; find-relative-path and rejects paths containing an 'up element.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (library-contains-audio-file? libraries file)
(cond
((not (path-string? file)) #f)
((not (file-exists? file)) #f)
((not (audio-file? file)) #f)
(else
(let ((full-file (complete-path/safe file)))
(if (eq? full-file #f)
#f
(let loop ((remaining libraries))
(if (null? remaining)
#f
(let ((root
(complete-path/safe
(music-library-root (car remaining)))))
(cond
((eq? root #f)
(loop (cdr remaining)))
((path-below-root? root full-file) #t)
(else
(loop (cdr remaining))))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Turn configured directory paths into music libraries.
; pre : Every value is a path or a (display-name path) list.
; post : No directory contents or audio metadata have been read.
; result : Libraries in configuration order, without duplicate roots.
; internals: specification-values separates each optional name from its path.
; map normalizes the paths and remove-duplicates compares their
; roots. The named loop calls named-root->music-library to validate
; each directory and assign its sequential library id.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-music-libraries specifications)
(define (specification-values specification)
(if (and (list? specification)
(= (length specification) 2)
(string? (car specification))
(path-string? (cadr specification)))
(values (string-trim (car specification))
(cadr specification))
(if (path-string? specification)
(values #f specification)
(raise-argument-error
'make-music-libraries
"(or/c path-string? (list/c string? path-string?))"
specification))))
(let ((roots
(remove-duplicates
(for/list ((specification (in-list specifications)))
(let-values (((name path)
(specification-values specification)))
(list name
(normal-case-path
(path->complete-path path)))))
(map (λ (specification)
(let-values (((name path)
(specification-values specification)))
(list name
(normal-case-path
(path->complete-path path)))))
specifications)
(λ (first second)
(equal? (cadr first) (cadr second))))))
(for/list ((named-root (in-list roots))
(index (in-naturals)))
(define configured-name (car named-root))
(define root (cadr named-root))
(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 (and configured-name
(not (string=? configured-name "")))
configured-name
(if name
(path->string name)
(path->string root)))
root)))))
(let loop ((remaining roots)
(index 0))
(if (null? remaining)
'()
(cons (named-root->music-library (car remaining) index)
(loop (cdr remaining) (add1 index)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read the artwork associated with a track.
; pre : Item names a local audio file.
; post : The audio file and optional neighbouring image remain unchanged.
; result : Embedded artwork, a conventional folder cover, or #f.
; internals: embedded-artwork first reads the picture stored in the audio tags.
; Only when that returns #f does cover-artwork search the track's
; directory for one of the names in cover-file-names.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (track-artwork item)
(define embedded
(with-handlers ((exn:fail? (λ (_) #f)))
(call-with-id3-tags
(track-file item)
(λ (tags)
(let ((picture (and (tags-valid? tags)
(tags-picture tags))))
(and picture
(artwork (let ((mime (id3-picture-mimetype picture)))
(if (and (string? mime)
(not (string=? mime "")))
mime
"application/octet-stream"))
(id3-picture-bytes picture))))))))
(or embedded
(with-handlers ((exn:fail? (λ (_) #f)))
(let* ((directory (or (path-only (track-file item))
(current-directory)))
(cover
(findf
(λ (candidate)
(let ((name (file-name-from-path candidate)))
(and name
(file-exists? candidate)
(member (path->string name)
cover-file-names
string-ci=?))))
(directory-list directory #:build? #t))))
(and cover
(let ((mime (mimetype-for-ext cover)))
(artwork (if (string? mime)
mime
"application/octet-stream")
(file->bytes cover))))))))
(let ((embedded (embedded-artwork item)))
(if (eq? embedded #f)
(cover-artwork item)
embedded)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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.
; internals: library-path resolves the requested directory. directory-list and
; path-kind supply filter-map with usable children; hidden-name?
; removes hidden containers. sort uses entry<? to put containers
; first and compare names without regard to case.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (browse-library library relative-path)
(let ((path (library-path library relative-path)))
@@ -267,13 +350,20 @@
(λ (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))))))
(cond
((eq? kind #f) #f)
((eq? kind 'container)
(if (hidden-name? name)
#f
(browser-entry
(path->string name)
kind
(append relative-path (list name)))))
(else
(browser-entry
(path->string name)
kind
(append relative-path (list name)))))))
(directory-list path))
entry<?)))
@@ -282,6 +372,9 @@
; 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.
; internals: A track entry is resolved by library-path and read by path->track.
; A container is passed to directory-tracks, which recursively calls
; browse-library and path->track in browser sort order.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (browser-entry->tracks library entry)
(if (eq? (browser-entry-kind entry) 'container)
@@ -292,18 +385,30 @@
(library-path library
(browser-entry-relative-path entry))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module library.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require rackunit)
(define root
(make-temporary-file "rkt-web-library-~a" 'directory))
(define outside-file
(make-temporary-file "rkt-web-outside-~a.mp3"))
(dynamic-wind
void
(λ ()
(make-directory (build-path root "Album"))
(make-directory (build-path root ".Hidden"))
(call-with-output-file
(build-path root "Album" "inside.mp3") void)
(call-with-output-file (build-path root "track.mp3") void)
(call-with-output-file (build-path root "cover.jpg") void)
(call-with-output-file (build-path root "ignored.txt") void)
(let* ((libraries (make-music-libraries (list root)))
(entries (browse-library (car libraries) '())))
(check-equal? (length libraries) 1)
@@ -312,6 +417,29 @@
(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)
(check-equal?
(length
(browser-entry->tracks (car libraries) (car entries)))
1)
(check-true
(library-contains-audio-file?
libraries
(build-path root "track.mp3")))
(check-true
(library-contains-audio-file?
libraries
(build-path root "Album" "inside.mp3")))
(check-false
(library-contains-audio-file?
libraries
(build-path root "cover.jpg")))
(check-false
(library-contains-audio-file?
libraries
outside-file))
(check-equal?
(length (make-music-libraries (list root root)))
1)
(check-equal?
(music-library-name
(car (make-music-libraries
@@ -324,4 +452,5 @@
"Track" "" "" #f "audio/mpeg")))
"image/jpeg")))
(λ ()
(delete-directory/files root))))
(delete-directory/files root)
(delete-file outside-file))))