308 lines
11 KiB
Racket
308 lines
11 KiB
Racket
#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)
|
|
(struct-out artwork)
|
|
make-music-libraries
|
|
browse-library
|
|
browser-entry->tracks
|
|
track-artwork)
|
|
|
|
(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)
|
|
|
|
(struct artwork
|
|
(mime-type data)
|
|
#:transparent)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define supported-extensions
|
|
(audio-supported-extensions))
|
|
|
|
(define cover-file-names
|
|
'("cover.jpg" "cover.jpeg" "cover.png"
|
|
"folder.jpg" "folder.jpeg" "folder.png"
|
|
"front.jpg" "front.jpeg" "front.png"))
|
|
|
|
(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 or a (display-name path) list.
|
|
; post : No directory contents or audio metadata have been read.
|
|
; result : Libraries in configuration order, without duplicate roots.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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)))))
|
|
(lambda (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)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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)
|
|
(check-equal?
|
|
(music-library-name
|
|
(car (make-music-libraries
|
|
(list (list "Luisterkamer" root)))))
|
|
"Luisterkamer")
|
|
(check-equal?
|
|
(artwork-mime-type
|
|
(track-artwork
|
|
(track (build-path root "track.mp3")
|
|
"Track" "" "" #f "audio/mpeg")))
|
|
"image/jpeg")))
|
|
(λ ()
|
|
(delete-directory/files root))))
|