535 lines
21 KiB
Racket
535 lines
21 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/file
|
|
racket/serialize
|
|
racket/port
|
|
racket/string
|
|
"private/file-walker.rkt"
|
|
"private/util.rkt"
|
|
"private/mail.rkt"
|
|
"private/flac-handling.rkt"
|
|
"private/opus-handling.rkt"
|
|
"private/log.rkt"
|
|
"private/store.rkt"
|
|
racket-audio
|
|
simple-log
|
|
simple-ini)
|
|
|
|
(provide audio-manager)
|
|
|
|
(store-config! #:kind 'keystore)
|
|
|
|
(define (audio-manager music-path opus-path #:log-level [log-level 'debug])
|
|
(let* ((ini-config-file (build-path music-path ".audio-manager.ini"))
|
|
(ini (file->ini ini-config-file))
|
|
(mail-oke (check-mail-config ini))
|
|
(report-flacs-with-id3 "FLAC files with id3 tags\n\n")
|
|
(report-flac "")
|
|
(report-opus "")
|
|
(file-db-path (build-path music-path ".audio-manager.db"))
|
|
(file-db-store (begin
|
|
(store-config! #:kind (ini-get ini
|
|
'manager
|
|
'storage-kind
|
|
'keystore))
|
|
(store-open file-db-path)))
|
|
(processed-dirs 0)
|
|
(processed-files 0)
|
|
(processed-opus 0)
|
|
(changed-files 0)
|
|
(unchanged-files 0)
|
|
(deleted-files 0)
|
|
(new-files 0)
|
|
(pictures-set 0)
|
|
(converted-files 0)
|
|
(copied-files 0)
|
|
(failed-converts 0)
|
|
(failed-copies 0)
|
|
(files-in-target 0)
|
|
(dirs-in-target 0)
|
|
(last-dirs-in-target -1)
|
|
(not-in-source 0)
|
|
(jobs 0)
|
|
(max-jobs (ini-get ini 'audio-manager 'max-jobs 6))
|
|
(job-nr 0)
|
|
(processed-kind (make-hash))
|
|
(base-rate (ini-get ini 'flac 'max-khz 48000))
|
|
(dirs-logged -1)
|
|
(known-audio-exts '(mp3 flac opus mp4 m4a mpg ape wav))
|
|
(known-exts (append known-audio-exts
|
|
'(jpg jpeg png pdf)))
|
|
(unknown-exts '())
|
|
)
|
|
|
|
(define (kinds< a b)
|
|
(string<? (symbol->string a) (symbol->string b)))
|
|
|
|
(define (needs-processing? path info)
|
|
(let ((state (hash-ref info 'file-db #f)))
|
|
(and (eq? (hash-ref info 'type #f) 'file)
|
|
(not-hidden? path)
|
|
(or
|
|
(eq? state 'changed)
|
|
(eq? state 'new)))))
|
|
|
|
(define (needs-copying? path info #:copy [copy 'pure])
|
|
(let ((state (hash-ref info 'file-db #f)))
|
|
(and (eq? (hash-ref info 'type #f) 'file)
|
|
(not (eq? state 'deleted))
|
|
(not-hidden? path)
|
|
(let ((path-part (get-path-part info)))
|
|
(if (eq? path-part #f)
|
|
#f
|
|
(if (and (eq? state 'unchanged)
|
|
(let ((file (if (eq? copy 'pure)
|
|
(build-path opus-path path-part)
|
|
(path-replace-extension (build-path opus-path path-part) #".opus"))))
|
|
(file-exists? file)))
|
|
#f
|
|
#t)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (deleted? info)
|
|
(eq? (hash-ref info 'file-db #f) 'deleted))
|
|
|
|
(define (get-path-part info)
|
|
(let ((p (hash-ref info 'path #f)))
|
|
(unless (eq? p #f)
|
|
(let ((path (build-path
|
|
(os-path
|
|
(if (string? p) p (path->string p))))))
|
|
path))))
|
|
|
|
(define (flac-id3? info)
|
|
(and
|
|
(eq? (hash-ref info 'type) 'file)
|
|
(eq? (hash-ref info 'ext) 'flac)
|
|
(eq? (hash-ref info 'sniffed #f) 'mp3)))
|
|
|
|
(define (presumed-flac? info)
|
|
(and (eq? (hash-ref info 'type) 'file)
|
|
(eq? (hash-ref info 'ext) 'flac)))
|
|
|
|
(define (flac? path info)
|
|
(if (presumed-flac? info)
|
|
(let ((s (hash-ref info 'sniffed #f)))
|
|
(when (eq? s #f)
|
|
(set! s (audio-sniff-format path))
|
|
(hash-set! info 'sniffed s))
|
|
(eq? s 'flac))
|
|
#f))
|
|
|
|
(define (opus? info)
|
|
(and (eq? (hash-ref info 'type) 'file)
|
|
(eq? (hash-ref info 'ext) 'opus)))
|
|
|
|
(define (rep-id3 path)
|
|
(set! report-flacs-with-id3
|
|
(string-append report-flacs-with-id3
|
|
(format "- ~a\n" path))))
|
|
|
|
(define (rep-flac msg)
|
|
(set! report-flac
|
|
(string-append report-flac
|
|
"- " msg "\n")))
|
|
|
|
(define (rep-opus msg)
|
|
(set! report-opus
|
|
(string-append report-opus
|
|
"- " msg "\n")))
|
|
|
|
(define (adjust-ext base-path path info)
|
|
(let ((ext (hash-ref info 'ext)))
|
|
(hash-set! info 'orig-ext ext)
|
|
(unless (eq? ext '||)
|
|
(unless (memq ext known-exts)
|
|
(hash-set! info 'ext 'unknown)
|
|
(unless (memq ext unknown-exts)
|
|
(set! unknown-exts (sort (cons ext unknown-exts)
|
|
kinds<))
|
|
)
|
|
))
|
|
(values base-path path info)))
|
|
|
|
(define (flac-with-id3 base-path path info)
|
|
(if (or (needs-processing? path info)
|
|
(and
|
|
(eq? (hash-ref info 'type #f) 'file)
|
|
(eq? (hash-ref info 'sniffed #f) #f)
|
|
(not (deleted? info))))
|
|
(let ((ext (hash-ref info 'ext)))
|
|
(when (memq ext known-audio-exts)
|
|
(let ((sniffed (audio-sniff-format path)))
|
|
(hash-set! info 'sniffed sniffed)
|
|
(when (flac-id3? info)
|
|
(rep-id3 path))
|
|
)
|
|
))
|
|
(when (flac-id3? info)
|
|
(rep-id3 path))
|
|
)
|
|
(values base-path path info))
|
|
|
|
(define (flac-khz-bits base-path path info)
|
|
(when (and (needs-processing? path info) (flac? path info))
|
|
(let-values (((khz bits) (determine-flac-khz-and-bits path)))
|
|
(hash-set! info 'khz khz)
|
|
(hash-set! info 'bits bits)
|
|
)
|
|
)
|
|
(values base-path path info))
|
|
|
|
(define (flac-convert base-path path info)
|
|
(when (and (needs-processing? path info) (flac? path info))
|
|
(let ((rate (hash-ref info 'khz 0)))
|
|
(when (> rate base-rate)
|
|
(info-am "Need to convert flac file ~a (rate = ~a)" path rate)
|
|
(rep-flac (format "Convert ~a from ~a to ~a\n" path rate base-rate))
|
|
(if (convert-flac-to-rate path base-rate)
|
|
(begin
|
|
(hash-set! info 'khz base-rate)
|
|
(reset-file-admin-info path info)
|
|
)
|
|
(begin
|
|
(err-am " Cannot convert!")
|
|
(rep-flac " CANNOT CONVERT!")))
|
|
)
|
|
)
|
|
)
|
|
(values base-path path info))
|
|
|
|
(define (flac-picture base-path path info)
|
|
(when (and (needs-processing? path info) (flac? path info))
|
|
(let ((t (id3-tags path)))
|
|
(when (eq? (tags-picture t) #f)
|
|
(let-values (((kind cover-file) (get-cover-file path)))
|
|
(unless (eq? cover-file #f)
|
|
(info-am "Flac file has no picture, cover/folder.jpg|png available, setting picture")
|
|
(let ((cover (if (eq? kind 'jpg)
|
|
(make-tags-picture "image/jpeg"
|
|
'front-cover
|
|
(file->bytes cover-file)
|
|
#:description "Cover")
|
|
(make-tags-picture "image/png"
|
|
'front-cover
|
|
(file->bytes cover-file)
|
|
#:description "Cover"))
|
|
))
|
|
(call-with-id3-tags path
|
|
(λ (tags)
|
|
(tags-picture! tags cover)
|
|
(tags-save! tags))
|
|
#:mode 'read-write))
|
|
(reset-file-admin-info path info)
|
|
(info-am " Picture set")
|
|
(set! pictures-set (+ pictures-set 1))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(values base-path path info))
|
|
|
|
|
|
;; Converteer naar opus indien nodig en flac.
|
|
(define (to-opus base-path path info)
|
|
(when (and (or (needs-processing? path info)
|
|
(needs-copying? path info #:copy 'opus))
|
|
(flac? path info))
|
|
(let ((path-part (get-path-part info)))
|
|
(unless (eq? path-part #f)
|
|
(let ((opus-file (path-replace-extension
|
|
(build-path opus-path path-part)
|
|
#".opus")))
|
|
(set! processed-opus (+ processed-opus 1))
|
|
(info-am "Converting flac to opus: ~a" opus-file)
|
|
(rep-opus
|
|
(format "Converting flac to opus in thread: ~a" (basename opus-file)))
|
|
|
|
|
|
(let loop ()
|
|
(if (= jobs max-jobs)
|
|
(begin
|
|
(sleep 0.1)
|
|
(loop))
|
|
(begin
|
|
(set! job-nr (+ job-nr 1))
|
|
(set! jobs (+ jobs 1))
|
|
(let ((jobnr job-nr))
|
|
(thread
|
|
(λ ()
|
|
(with-handlers ([exn? (λ (e)
|
|
(set! failed-converts (+ failed-converts 1))
|
|
(err-am "Conversion of ~a: ~a" path e))])
|
|
(unless (directory-exists? (basedir opus-file))
|
|
(make-directory* (basedir opus-file)))
|
|
(info-am " Starting conversion job ~a" jobnr)
|
|
(if (convert-to-opus path opus-file ini)
|
|
(begin
|
|
(set! converted-files (+ converted-files 1))
|
|
(reset-file-admin-info path info)
|
|
(info-am " Converted ~a, job-nr = ~a" converted-files jobnr)
|
|
)
|
|
(begin
|
|
(info-am " CONVERSION PROBLEM, job-nr = ~a" jobnr)
|
|
(rep-opus " Conversion failed!")
|
|
(set! failed-converts (+ failed-converts 1))
|
|
)
|
|
)
|
|
(set! jobs (- jobs 1))
|
|
)
|
|
)
|
|
#:pool 'own
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
))
|
|
(values base-path path info))
|
|
|
|
;; Kopieer bestanden rechtstreeks indien nodig en geen flac
|
|
(define (copy-other base-path path info)
|
|
(when (and (needs-copying? path info)
|
|
(not (presumed-flac? info)))
|
|
(with-handlers ([exn? (λ (e)
|
|
(set! failed-copies (+ failed-copies 1))
|
|
(err-am "Copy file ~a: ~a" path e))])
|
|
(let ((path-part (get-path-part info)))
|
|
(unless (eq? path-part #f)
|
|
(let ((dest-path (build-path opus-path path-part)))
|
|
(unless (directory-exists? (basedir dest-path))
|
|
(make-directory* (basedir dest-path)))
|
|
(rep-opus (format "Copying: ~a" path-part))
|
|
(copy-file path dest-path #:exists-ok? #t)
|
|
(set! copied-files (+ copied-files 1)))))
|
|
)
|
|
)
|
|
(values base-path path info))
|
|
|
|
(define (deleter base-path path info)
|
|
(when (deleted? info)
|
|
(let ((path-part (get-path-part info)))
|
|
(unless (eq? path-part #f)
|
|
(let ((rm-path (build-path opus-path
|
|
(if (presumed-flac? info)
|
|
(path-replace-extension path-part #".opus")
|
|
path-part))))
|
|
(delete-directory/files rm-path #:must-exist? #f)
|
|
(let ((normalized-sub-path (hash-ref info 'path)))
|
|
(store-remove! file-db-store normalized-sub-path))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(values base-path path info))
|
|
|
|
(define (updater base-path path info)
|
|
(when (not (eq? (hash-ref info 'file-db #f) 'deleted))
|
|
(let ((normalized-sub-path (hash-ref info 'path)))
|
|
(store-set! file-db-store normalized-sub-path info)))
|
|
(values base-path path info))
|
|
|
|
(define (target-tree-cleaner base-path path info)
|
|
(if (eq? (hash-ref info 'type #f) 'dir)
|
|
(set! dirs-in-target (+ dirs-in-target 1))
|
|
(set! files-in-target (+ files-in-target 1)))
|
|
|
|
(when (or (and
|
|
(= (remainder dirs-in-target 100) 0)
|
|
(> (quotient dirs-in-target 100) last-dirs-in-target))
|
|
(= (remainder files-in-target 1000) 0))
|
|
(set! last-dirs-in-target (quotient dirs-in-target 100))
|
|
(info-am "Files in target checked: ~a, dirs: ~a" files-in-target dirs-in-target)
|
|
(sync-log-am)
|
|
)
|
|
(let ((normalized-sub-path (hash-ref info 'path)))
|
|
(when (opus? info)
|
|
(set! normalized-sub-path (path-replace-extension normalized-sub-path #".flac")))
|
|
(unless (store-exists? file-db-store normalized-sub-path)
|
|
(info-am "Not in source: ~a" normalized-sub-path)
|
|
(delete-directory/files path #:must-exist? #f)
|
|
(sync-log-am)
|
|
(set! not-in-source (+ not-in-source 1)))
|
|
(values base-path path info)))
|
|
|
|
(define (log-processed-file base-path path info)
|
|
(dbg-am "processing ~a" path)
|
|
|
|
(if (eq? (hash-ref info 'type) 'dir)
|
|
(set! processed-dirs (+ processed-dirs 1))
|
|
(begin
|
|
(set! processed-files (+ processed-files 1))
|
|
(let ((k (hash-ref info 'file-db 'unknown)))
|
|
(cond ((eq? k 'new) (set! new-files (+ new-files 1)))
|
|
((eq? k 'changed) (set! changed-files (+ changed-files 1)))
|
|
((eq? k 'deleted) (set! deleted-files (+ deleted-files 1)))
|
|
((eq? k 'unchanged) (set! unchanged-files (+ unchanged-files 1)))
|
|
))
|
|
(let* ((ext (hash-ref info 'ext))
|
|
(n (hash-ref processed-kind ext 0)))
|
|
(set! n (+ n 1))
|
|
(hash-set! processed-kind ext n)))
|
|
)
|
|
|
|
(when (or (= (remainder processed-dirs 100) 0)
|
|
(= (remainder processed-files 1000) 0))
|
|
(unless (= dirs-logged processed-dirs)
|
|
(set! dirs-logged processed-dirs)
|
|
(info-am (format "processed dirs: ~a, files: ~a, kinds: ~a, unknown kinds: ~a"
|
|
processed-dirs
|
|
processed-files
|
|
(string-join
|
|
(map (λ (ext)
|
|
(format "~a: ~a" ext (hash-ref processed-kind ext)))
|
|
(sort (hash-keys processed-kind)
|
|
kinds<))
|
|
", ")
|
|
(string-join
|
|
(map (λ (ext) (symbol->string ext)) unknown-exts)
|
|
", ")
|
|
))
|
|
(sync-log-am)
|
|
))
|
|
|
|
(when (flac-id3? info)
|
|
(warn-am (format " FLAC heeft een id3v2 tag: ~a" path)))
|
|
|
|
(values base-path path info))
|
|
|
|
(define (report)
|
|
(rep-flac (format "Processed ~a flac files"
|
|
(hash-ref processed-kind 'flac 0)))
|
|
(rep-opus (format "Processed ~a opus files"
|
|
processed-opus))
|
|
(let* ((message (list "FLACS with id3 tags\n"
|
|
"-------------------\n"
|
|
report-flacs-with-id3
|
|
"\n"
|
|
"FLAC report\n"
|
|
"-----------\n"
|
|
report-flac
|
|
"OPUS report\n"
|
|
"-----------\n"
|
|
report-opus
|
|
"File report\n"
|
|
"-----------\n"
|
|
(format "Processed ~a files" processed-files)
|
|
(format "Processed ~a directories" processed-dirs)
|
|
(format "Deleted files : ~a" deleted-files)
|
|
(format "New files : ~a" new-files)
|
|
(format "Changed files : ~a" changed-files)
|
|
(format "Unchanged files: ~a" unchanged-files)
|
|
(format "Pictures set : ~a" pictures-set)
|
|
(format "Converted files: ~a" converted-files)
|
|
(format "Copied files : ~a" copied-files)
|
|
(format "Failed convert : ~a" failed-converts)
|
|
(format "Failed copies : ~a" failed-copies)
|
|
(format "Files in target: ~a" files-in-target)
|
|
(format "Dirs in target : ~a" dirs-in-target)
|
|
(format "Not in source : ~a" not-in-source)
|
|
))
|
|
(subj (format "Audio manager report d.d. ~a" (date->yyyy-mm-dd (now))))
|
|
)
|
|
(mail-report ini
|
|
subj
|
|
message)
|
|
)
|
|
)
|
|
|
|
|
|
(sl-log-to-file&display (build-path music-path ".audio-manager.log"))
|
|
(info-am "Setting log level to ~a" log-level)
|
|
(sl-set-log-level log-level)
|
|
|
|
(let ((fw (make-file-admin music-path file-db-store #:filename-cleaner clean-audio-basename)))
|
|
;; Enrichment phase
|
|
(set! fw (fw-add-step fw adjust-ext))
|
|
(set! fw (fw-add-step fw flac-with-id3))
|
|
(set! fw (fw-add-step fw flac-khz-bits))
|
|
;; Conversion phase
|
|
(set! fw (fw-add-step fw flac-convert))
|
|
(set! fw (fw-add-step fw flac-picture))
|
|
(set! fw (fw-add-step fw to-opus))
|
|
(set! fw (fw-add-step fw copy-other))
|
|
;; Cleanup/Logging phase/updating
|
|
(set! fw (fw-add-step fw deleter))
|
|
(set! fw (fw-add-step fw log-processed-file))
|
|
(set! fw (fw-add-step fw updater))
|
|
|
|
(let loop ()
|
|
(let-values (((base-path path info) (fw)))
|
|
(if (eq? info #f)
|
|
(begin
|
|
; Wait for all conversions to finish
|
|
(let loop ()
|
|
(if (= jobs 0)
|
|
#t
|
|
(begin
|
|
(sleep 0.1)
|
|
(loop))))
|
|
; Process Rest.
|
|
(info-am "Finished walking music library")
|
|
;; Cleanup files in target, not in source
|
|
(info-am "Checking files in target, not in source")
|
|
(let ((fwt (make-file-walker opus-path "*" target-tree-cleaner #:clean-os-name #f)))
|
|
(let loop1 ()
|
|
(let-values (((base-path path info) (fwt)))
|
|
(if (eq? info #f)
|
|
(begin
|
|
(info-am "Target check finished, not in source: ~a" not-in-source)
|
|
(info-am "Files in target checked: ~a" files-in-target))
|
|
(loop1)))))
|
|
(info-am "Closing store")
|
|
(store-close file-db-store)
|
|
(info-am "Reporting")
|
|
(report)
|
|
(info-am "Done")
|
|
'done)
|
|
(loop))))
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
(require racket/string)
|
|
|
|
(define (clean-audio-basename name)
|
|
(let* ((s0 (format "~a" name))
|
|
|
|
;; Laatste .ext apart houden, zodat we alleen de stem opschonen.
|
|
;; "Gypsy Festival vol. 2" blijft dus gewoon een directorynaam.
|
|
(m (regexp-match #px"^(.*)(\\.[A-Za-z0-9][A-Za-z0-9_-]{0,15})$" s0))
|
|
(stem0 (if m (list-ref m 1) s0))
|
|
(ext (if m (list-ref m 2) ""))
|
|
|
|
;; Audio-technische suffixen verwijderen:
|
|
;; [16B-44.1kHz], [24B-44.1kHz], [24bit-96 kHz], etc.
|
|
(stem1 (regexp-replace*
|
|
#px"(?i:\\s*\\[(16|24|32)\\s*(b|bit)\\s*[-_ ]\\s*[0-9]+(?:\\.[0-9]+)?\\s*k\\s*hz\\]\\s*)"
|
|
stem0
|
|
" "))
|
|
|
|
;; Underscores als simpele titel-markering opruimen:
|
|
;; _Rosamunde_ -> Rosamunde
|
|
;; Schubert_ String -> Schubert String
|
|
;;
|
|
;; Bewust geen liggende streepjes normaliseren.
|
|
(stem2 (regexp-replace* #px"_+" stem1 " "))
|
|
|
|
;; Whitespace normaliseren.
|
|
(stem3 (regexp-replace* #px"\\s+" stem2 " "))
|
|
|
|
;; Alleen de stem trimmen.
|
|
;; Geen '-' trimmen; dat is een gewoon teken.
|
|
(stem4 (string-trim stem3 " ."))
|
|
|
|
(stem5 (if (string=? stem4 "") "_" stem4)))
|
|
(string-append (string-trim stem5) (string-trim ext))))
|