diff --git a/.gitignore b/.gitignore index 6bd7bf8..3ba7d93 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ compiled/ *.dep /private/*.bak +/*.bak diff --git a/audio-manager.rkt b/audio-manager.rkt new file mode 100644 index 0000000..2f04047 --- /dev/null +++ b/audio-manager.rkt @@ -0,0 +1,369 @@ +#lang racket/base + +(require racket/file) +(require racket/serialize) +(require racket/string) +(require "private/file-walker.rkt") +(require "private/util.rkt") +(require "private/mail.rkt") +(require "private/flac-handling.rkt") +(require "private/opus-handling.rkt") +(require "private/log.rkt") +(require racket-audio) +(require simple-log) +(require simple-ini) + +(provide audio-manager) + +(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)) + (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-hash (if (file-exists? file-db-path) + (deserialize (file->value file-db-path)) + (make-hash) + )) + (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) + (processed-kind (make-hash)) + (base-rate (ini-get ini 'flac 'max-khz 48000)) + (dirs-logged -1) + (known-exts '(mp3 flac opus mp4 m4a mpg jpg jpeg png pdf)) + (unknown-exts '()) + ) + + (define (kinds< a b) + (stringstring 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? info) + (and (eq? (hash-ref info 'type #f) 'file) + (not (eq? (hash-ref info 'file-db #f) 'deleted)) + (let ((path-part (get-path-part info))) + (if (eq? path-part #f) + #f + (not (file-exists? (build-path opus-path path-part))))))) + + (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 (flac? path info) + (when (eq? (hash-ref info 'type) 'file) + (let ((s (hash-ref info 'sniffed #f))) + (when (eq? s #f) + (hash-set! info 'sniffed (audio-sniff-format path)) + ))) + (and + (eq? (hash-ref info 'type) 'file) + (eq? (hash-ref info 'ext) 'flac) + (eq? (hash-ref info 'sniffed) 'flac) + ) + ) + + (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 'unkown) + (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 (needs-processing? path info) + (when (eq? (hash-ref info 'ext) 'flac) + (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)) + (when (or (eq? (hash-ref info 'khz #f) #f) + (eq? (hash-ref info 'bits #f) #f)) + (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) + (hash-set! info 'khz base-rate) + (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)) + (info-am " Picture set") + (set! pictures-set (+ pictures-set 1)) + ) + ) + ) + ) + ) + (values base-path path info)) + + (define (to-opus base-path path info) + (when (or (needs-processing? path info) + (needs-copying? info)) + (if (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)) + (unless (file-exists? opus-file) + (rep-opus + (format "Converting flac to opus: ~a" (basename opus-file))) + (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))) + (if (convert-to-opus path opus-file ini) + (begin + (set! converted-files (+ converted-files 1)) + (info-am " Converted") + ) + (begin + (info-am " CONVERSION PROBLEM") + (rep-opus " Conversion failed!") + (set! failed-converts (+ failed-converts 1)) + ) + ) + ) + ) + ) + ) + ) + (begin ; copy files rechtstreeks indien nodig + (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))) + (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 path-part))) + (delete-directory/files rm-path #:must-exist? #f) + (let ((normalized-sub-path (hash-ref info 'path))) + (hash-remove! file-db-hash normalized-sub-path)) + ) + ) + ) + ) + (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 10) 0) + (= (remainder processed-files 250) 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) + ", ") + )) + )) + + (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) + )) + (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-hash))) + (set! fw (fw-add-filter fw adjust-ext)) + (set! fw (fw-add-filter fw flac-with-id3)) + (set! fw (fw-add-filter fw flac-khz-bits)) + (set! fw (fw-add-filter fw flac-convert)) + (set! fw (fw-add-filter fw flac-picture)) + (set! fw (fw-add-filter fw to-opus)) + (set! fw (fw-add-filter fw deleter)) + (set! fw (fw-add-filter fw log-processed-file)) + (let loop () + (let-values (((base-path path info) (fw))) + (if (eq? info #f) + (begin + (info-am "Finished walking music library") + (write-to-file (serialize file-db-hash) file-db-path #:exists 'replace) + (report) + 'done) + (loop)))) + ) + ) + ) + + diff --git a/private/file-walker.rkt b/private/file-walker.rkt index 8e078ad..99dd475 100644 --- a/private/file-walker.rkt +++ b/private/file-walker.rkt @@ -7,10 +7,16 @@ file/glob) (provide make-file-walker + make-file-admin + fw-add-filter + os-path ) +(define (os-path str) + (let ((delim (if (eq? (system-path-convention-type) 'windows) "\\" "/"))) + (string-replace str "/" delim))) -(define (make-file-walker base-path glob-pattern callback) +(define (make-file-walker base-path glob-pattern filter-func) (let* ((gen (sequence->generator (sequence-filter (λ (p) @@ -28,27 +34,115 @@ (λ () (let ((path (gen))) (if (void? path) - result + (values #f #f #f) (let* ((str-path (path->string path)) (ext* (path-get-extension path)) - (ext (substring - (if (eq? ext* #f) - "." - (bytes->string/utf-8 ext*)) 1)) + (ext (string->symbol + (substring + (if (eq? ext* #f) + "." + (let ((e (string-downcase (bytes->string/utf-8 ext*)))) + (if (string-contains? e " ") + "." + e))) 1))) (path-part (substring str-path base-path-len)) (str-n-path (string-replace path-part "\\" "/")) - (info (if (directory-exists? path) - (list 'dir str-n-path ext) - (list 'file str-n-path ext - (file-size path) - (file-or-directory-modify-seconds path)) - )) + (info (let ((h (make-hash (list + (cons 'type 'dir) + (cons 'path str-n-path) + (cons 'ext ext))))) + (when (file-exists? path) + (hash-set! h 'type 'file) + (hash-set! h 'size (file-size path)) + (hash-set! h 'mtime (file-or-directory-modify-seconds path)) + ) + h)) ) - (set! result (callback (eq? (car info) 'dir) - base-path - path - path-part ext info)) - 'more)))) + (filter-func base-path path info))) + ) + ) ) ) - \ No newline at end of file + +(define (make-file-admin base-path db-hash) + + (define (file-info-equal? i1 i2) + (if (eq? (hash-ref i1 'type) (hash-ref i2 'type)) + (if (eq? (hash-ref i1 'type) 'file) + (and + (string=? (hash-ref i1 'path) (hash-ref i2 'path)) + (= (hash-ref i1 'size) (hash-ref i2 'size)) + (= (hash-ref i1 'mtime) (hash-ref i2 'mtime))) + (string=? (hash-ref i1 'path) (hash-ref i2 'path)) + ) + #f)) + + (define (file-admin base-path path info) + (let* ((normalized-sub-path (hash-ref info 'path)) + (in-db (hash-ref db-hash normalized-sub-path #f)) + ) + (cond + ((eq? in-db #f) + (hash-set! info 'file-db 'new) + (hash-set! db-hash normalized-sub-path info) + ) + (else + (if (file-info-equal? info in-db) + (hash-set! info 'file-db 'unchanged) + (hash-set! info 'file-db 'changed)) + (hash-set! db-hash normalized-sub-path info) + ) + ) + (values base-path path info) + )) + + (define (init-db-sweep) + (hash-for-each db-hash + (λ (key value) + (if (eq? (hash-ref value 'file-db #f) 'deleted) + (hash-remove! db-hash key) + (hash-set! value 'file-db 'unknown))))) + + (define (get-deleted) + (let ((keys (hash-keys db-hash))) + (map (λ (key) + (let ((info (hash-ref db-hash key))) + (hash-set! info 'file-db 'deleted) + info)) + (filter (λ (key) + (let ((v (hash-ref db-hash key))) + (eq? (hash-ref v 'file-db) 'unknown))) + keys)))) + + (let* ((fw (make-file-walker base-path "*" file-admin)) + (deleted #f)) + (init-db-sweep) + (letrec ((f (λ () + (if (list? deleted) + (if (null? deleted) + (values #f #f #f) + (let ((r (car deleted))) + (set! deleted (cdr deleted)) + (values base-path (build-path base-path (os-path (hash-ref r 'path))) r)) + ) + (let-values (((base-path path info) (fw))) + (if (eq? info #f) + (begin + (set! deleted (get-deleted)) + (f)) + (values base-path path info)) + ) + ) + ) + )) + f)) + ) + +(define (fw-add-filter fw filter-func) + (λ () + (let-values (((base-path path info) (fw))) + (if (eq? info #f) + (values #f #f #f) + (filter-func base-path path info)))) + ) + diff --git a/private/flac-handling.rkt b/private/flac-handling.rkt new file mode 100644 index 0000000..0ffe393 --- /dev/null +++ b/private/flac-handling.rkt @@ -0,0 +1,50 @@ +#lang racket/base +(require racket-audio/flac-decoder + racket-audio/audio-encoder + "log.rkt" + ) + +(provide determine-flac-khz-and-bits + convert-flac-to-rate) + + +(define (determine-flac-khz-and-bits path) + (with-handlers ((exn? (λ args + (error (format "Cannot process ~a" path))))) + (let* ((meta #f) + (flac-handle (flac-open path + (λ (info) (set! meta info)) + (λ data #t))) + ) + (flac-read-meta flac-handle) + (flac-stop flac-handle) + (if (eq? meta #f) + (values #f #f) + (values (hash-ref meta 'sample-rate) + (hash-ref meta 'audio-bits-per-sample)) + ) + ) + ) + ) + + +(define (convert-flac-to-rate path rate) + (let* ((tmp-file (build-path (string-append (path->string path) ".tmp.flac"))) + (encoder-settings (hash 'target-sample-rate rate + 'compression-level 8)) + ) + (with-handlers ([exn? (λ (e) + (err-am (format "~a" e)) + (when (file-exists? tmp-file) + (delete-file tmp-file)) + #f)]) + (let ((result (audio-encode path tmp-file + encoder-settings + #:encoder 'flac + #:copy-tags? #t + ))) + (rename-file-or-directory tmp-file path #t) + #t) + ) + ) + ) diff --git a/private/log.rkt b/private/log.rkt index e3e6c53..dddb9a9 100644 --- a/private/log.rkt +++ b/private/log.rkt @@ -1,22 +1,17 @@ #lang racket/base -(require racket/file - simple-log) +(require simple-log) -(provide setup-logging! - dbg-alm - info-alm - warn-alm - err-alm - fatal-alm - sync-log-alm) +(provide dbg-am + info-am + warn-am + err-am + fatal-am + sync-log-am) -(sl-def-log audio-library-manager alm) +(define log-defined #f) +(displayln (format "log-defined: ~a" log-defined)) +(set! log-defined #t) + +(sl-def-log audio-manager am) -(define (setup-logging! log-file display-log?) - (make-directory* (let-values ([(base name dir?) (split-path log-file)]) base)) - (if display-log? - (sl-log-to-file&display log-file) - (sl-log-to-file log-file)) - (sl-set-log-level 'debug) - (info-alm "logging initialized: ~a" log-file)) diff --git a/private/mail.rkt b/private/mail.rkt index 0eb93ba..12a4a4d 100644 --- a/private/mail.rkt +++ b/private/mail.rkt @@ -1,149 +1,28 @@ #lang racket/base -(require racket/list - racket/string - racket/tcp - net/base64 - "manager-ini.rkt" - "report.rkt") +(require net/smtp + net/head + simple-ini) -(provide maybe-send-report-mail - mail-address->envelope-address - strict-send-smtp-mail) +(provide mail-report) -(define (smtp-proc name) - (dynamic-require 'smtp name)) +(define (mail-report ini subject report) + (let* ((get (λ (key msg) + (let ((v (ini-get ini 'mail key 'nil))) + (when (eq? v 'nil) + (error msg)) + v))) + (from (get 'from "configure from address as name ")) + (to (get 'to "configure to address as name ")) + (server (get 'server "configure the smtp server")) + (port (ini-get ini 'mail 'port 25)) + ) + (let* ((hdr (standard-message-header from (list to) '() '() subject))) + (smtp-send-message server from (list to) hdr + (if (list? report) report (list report)) + #:port-no port) + ) + ) + ) -(define (non-empty-string? v) - (and (string? v) (not (string=? (string-trim v) "")))) - -(define (base64-line s) - (bytes->string/utf-8 (base64-encode (string->bytes/utf-8 (or s "")) #""))) - -(define (trim-envelope-address s) - (define t (string-replace s "\"" "")) - (regexp-replace* #rx"^[<> \t\r\n]+|[<> \t\r\n]+$" t "")) - -(define (mail-address->envelope-address v) - (define s (string-trim (format "~a" v))) - (define m (regexp-match #px"<([^<>]+)>" s)) - (define addr (if m (cadr m) s)) - (trim-envelope-address addr)) - -(define (clean-address-list xs) - (filter non-empty-string? - (for/list ([x (in-list xs)]) - (mail-address->envelope-address x)))) - -(define (write-smtp-command out command) - (display (string-append (string-trim command) "\r\n") out) - (flush-output out)) - -(define (read-smtp-response in expected host) - (let loop ([lines '()]) - (define line (read-line in 'any)) - (when (eof-object? line) - (error 'strict-send-smtp-mail "smtp server ~a: unexpected EOF" host)) - (define lines* (cons line lines)) - (define ok-code? - (and (>= (string-length line) 3) - (equal? (substring line 0 3) (number->string expected)))) - (unless ok-code? - (error 'strict-send-smtp-mail "smtp server ~a:\n ~a" host (string-join (reverse lines*) "\n "))) - (if (and (> (string-length line) 3) (char=? (string-ref line 3) #\-)) - (loop lines*) - (reverse lines*)))) - -(define (strict-send-smtp-mail mail - #:host host - #:port port - #:tls-encode [tls-encode #f] - #:username [username ""] - #:password [password ""]) - ;; The smtp package writes commands as "MAIL FROM: " and - ;; "RCPT TO: ". Some servers reject the whitespace before the path. - ;; This sender keeps using smtp's mail struct and MIME header generation, - ;; but sends the SMTP envelope as "MAIL FROM:" / "RCPT TO:". - (when tls-encode - (error 'strict-send-smtp-mail "TLS/STARTTLS is not supported by the strict sender yet")) - (define mail-sender (smtp-proc 'mail-sender)) - (define mail-recipients (smtp-proc 'mail-recipients)) - (define mail-cc-recipients (smtp-proc 'mail-cc-recipients)) - (define mail-bcc-recipients (smtp-proc 'mail-bcc-recipients)) - (define mail-header (smtp-proc 'mail-header)) - (define sender (mail-address->envelope-address (mail-sender mail))) - (define recipients (append (clean-address-list (mail-recipients mail)) - (clean-address-list (mail-cc-recipients mail)) - (clean-address-list (mail-bcc-recipients mail)))) - (unless (non-empty-string? host) - (error 'strict-send-smtp-mail "missing SMTP host")) - (unless (non-empty-string? sender) - (error 'strict-send-smtp-mail "missing SMTP sender")) - (when (null? recipients) - (error 'strict-send-smtp-mail "missing SMTP recipient")) - (define-values (in out) (tcp-connect host port)) - (dynamic-wind - void - (lambda () - (read-smtp-response in 220 host) - (write-smtp-command out "EHLO localhost.localdomain") - (read-smtp-response in 250 host) - (when (non-empty-string? username) - (write-smtp-command out "AUTH LOGIN") - (read-smtp-response in 334 host) - (write-smtp-command out (base64-line username)) - (read-smtp-response in 334 host) - (write-smtp-command out (base64-line password)) - (read-smtp-response in 235 host)) - (write-smtp-command out (format "MAIL FROM:<~a>" sender)) - (read-smtp-response in 250 host) - (for ([r (in-list recipients)]) - (write-smtp-command out (format "RCPT TO:<~a>" r)) - (read-smtp-response in 250 host)) - (write-smtp-command out "DATA") - (read-smtp-response in 354 host) - (display (mail-header mail) out) - (display "\r\n.\r\n" out) - (flush-output out) - (read-smtp-response in 250 host) - (write-smtp-command out "QUIT") - (read-smtp-response in 221 host)) - (lambda () - (close-input-port in) - (close-output-port out)))) - -(define (maybe-send-report-mail ini summary errors - #:manager-name [manager-name "FLAC 48 kHz manager"] - #:result-label [result-label "converted"]) - (define has-errors? (positive? (summary-ref summary 'errors 0))) - (define should-send? - (and (ini-ref/bool ini 'mail 'enabled #f) - (not (null? (ini-ref/addresses ini 'mail 'to ""))) - (or (and has-errors? (ini-ref/bool ini 'mail 'send-on-error #t)) - (and (not has-errors?) (ini-ref/bool ini 'mail 'send-on-success #f))))) - (when should-send? - (define from (mail-address->envelope-address (ini-ref/string ini 'mail 'from ""))) - (define to (clean-address-list (ini-ref/addresses ini 'mail 'to ""))) - (define cc (clean-address-list (ini-ref/addresses ini 'mail 'cc ""))) - (define bcc (clean-address-list (ini-ref/addresses ini 'mail 'bcc ""))) - (define subject (format "~a ~a: ~a error(s), ~a ~a" - (ini-ref/string ini 'mail 'subject-prefix "[flac-48khz-manager]") - manager-name - (summary-ref summary 'errors 0) - (summary-ref summary 'converted 0) - result-label)) - (define body (html-report subject summary errors)) - (define make-mail (smtp-proc 'make-mail)) - (define mail (make-mail subject body - #:from from - #:to to - #:cc cc - #:bcc bcc - #:body-content-type "text/html")) - (strict-send-smtp-mail mail - #:host (string-trim (ini-ref/string ini 'mail 'host "")) - #:port (ini-ref/int ini 'mail 'port 25) - #:tls-encode (ini-ref/bool ini 'mail 'tls #f) - #:username (string-trim (ini-ref/string ini 'mail 'username "")) - #:password (ini-ref/string ini 'mail 'password "")))) diff --git a/private/opus-handling.rkt b/private/opus-handling.rkt new file mode 100644 index 0000000..2498f6b --- /dev/null +++ b/private/opus-handling.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require racket-audio/audio-encoder + "log.rkt" + "util.rkt" + simple-ini + ) + +(provide convert-to-opus + ) + + +(define (convert-to-opus flac-in opus-out ini) + (let* ((opus-kbps (ini-get ini 'opus 'kbps 224)) + (settings (hash 'bitrate (* opus-kbps 1000) + 'vbr #t)) + ) + (with-handlers ([exn? (λ (e) + (err-am (format "~a" e)) + (when (file-exists? opus-out) + (delete-file opus-out)) + #f)]) + (let ((result (audio-encode flac-in opus-out + settings + #:encoder 'opus + #:copy-tags? #t))) + #t) + ) + ) + ) diff --git a/private/util.rkt b/private/util.rkt index 9bc4bbf..8ba672d 100644 --- a/private/util.rkt +++ b/private/util.rkt @@ -1,165 +1,54 @@ #lang racket/base -(require racket/file - racket/list +(require racket/date + racket/format racket/path - racket/string) + racket/string + ) -(provide bool-value - int-value - string-value - split-addresses - normalized-relpath-string - normalized-relpath->path - normalize-relpath-string - legacy-backslash-relpath-string - relpath-string - filesystem-path - flac-path? - opus-path? - manager-temp-path? - directory-file-paths - replace-path-extension - ensure-parent-directory! - alist-ref/default - alist-set) +(provide date->yyyy-mm-dd + now + get-cover-file + basename + basedir + not-hidden? + ) -(define (bool-value v [default #f]) - (cond [(boolean? v) v] - [(number? v) (not (zero? v))] - [(string? v) - (define s (string-downcase (string-trim v))) - (cond [(member s '("#t" "true" "yes" "y" "1" "on")) #t] - [(member s '("#f" "false" "no" "n" "0" "off" "")) #f] - [else default])] - [else default])) +(define (now) + (seconds->date (current-seconds))) -(define (int-value v [default 0]) - (cond [(integer? v) v] - [(number? v) (inexact->exact (round v))] - [(string? v) (or (string->number (string-trim v)) default)] - [else default])) +(define (date->yyyy-mm-dd d) + (format "~a-~a-~a" + (date-year d) + (~r (date-month d) #:min-width 2 #:pad-string "0") + (~r (date-day d) #:min-width 2 #:pad-string "0"))) -(define (string-value v [default ""]) - (cond [(string? v) v] - [(symbol? v) (symbol->string v)] - [(number? v) (number->string v)] - [(boolean? v) (if v "#t" "#f")] - [(not v) default] - [else (format "~a" v)])) +(define (get-cover-file path) + (let-values (((base name dir) (split-path path))) + (let ((names '((jpg "cover.jpg") (jpg "cover.jpeg") + (jpg "folder.jpg") (jpg "folder.jpeg") + (png "cover.png") (png "folder.png")))) + (letrec ((f (λ (l) + (if (null? l) + (values #f #f) + (if (file-exists? (build-path base (cadar l))) + (values (caar l) (build-path base (cadar l))) + (f (cdr l))))))) + (f names))))) -(define (split-addresses v) - (define s (string-value v "")) - (filter (lambda (x) (not (string=? x ""))) - (map string-trim (regexp-split #px"[,;]" s)))) +(define (basename path) + (file-name-from-path path)) -(define (windows-extended-path-string s) - (cond [(or (< (string-length s) 3) - (not (eq? (system-type 'os) 'windows)) - (string-prefix? s "\\\\?\\")) - s] - [(and (>= (string-length s) 2) - (char=? (string-ref s 0) #\\) - (char=? (string-ref s 1) #\\)) - (string-append "\\\\?\\UNC\\" (substring s 2))] - [(and (>= (string-length s) 3) - (char-alphabetic? (string-ref s 0)) - (char=? (string-ref s 1) #\:) - (char=? (string-ref s 2) #\\)) - (string-append "\\\\?\\" s)] - [else s])) +(define (basedir path) + (path-only path)) -(define (filesystem-path p) - (define s (cond [(path? p) (path->string p)] - [(string? p) p] - [else (raise-argument-error 'filesystem-path "path-string? or path?" p)])) - (simple-form-path (string->path (windows-extended-path-string s)))) -(define (replace-char s from to) - (list->string - (for/list ([ch (in-string s)]) - (if (char=? ch from) to ch)))) +(define (hidden-path? p) + (for/or ([part (in-list (explode-path p))]) + (and (path? part) + (let ([s (path->string part)]) + (and (string-prefix? s ".") + (not (member s '("." "..")))))))) -(define (normalize-relpath-string s) - (define normalized (replace-char s #\\ #\/)) - (when (or (string=? normalized "") - (regexp-match? #rx"^[A-Za-z]:" normalized) - (regexp-match? #rx"^/" normalized) - (regexp-match? #rx"(^|/)\\.\\.(/|$)" normalized)) - (raise-argument-error 'normalize-relpath-string "relative path without .." s)) - normalized) - -(define (legacy-backslash-relpath-string relpath) - (replace-char (normalize-relpath-string relpath) #\/ #\\)) - -(define (normalized-relpath-string base p) - (normalize-relpath-string - (path->string (find-relative-path (filesystem-path base) (filesystem-path p))))) - -(define relpath-string normalized-relpath-string) - -(define (normalized-relpath->path relpath) - (define parts (regexp-split #rx"/+" (normalize-relpath-string relpath))) - (when (ormap (lambda (part) (or (string=? part "") (string=? part "."))) parts) - (raise-argument-error 'normalized-relpath->path "relative normalized path" relpath)) - (apply build-path parts)) - -(define (extension-ci=? p ext) - (let-values ([(base name dir?) (split-path p)]) - (and (path? name) - (let ([e (path-get-extension name)]) - (and e (string-ci=? (bytes->string/utf-8 e) ext)))))) - -(define (file-exists?/quiet p) - (with-handlers ([exn:fail? (lambda (_) #f)]) (file-exists? p))) - -(define (flac-path? p) - (and (file-exists?/quiet p) (extension-ci=? p ".flac"))) - -(define (opus-path? p) - (and (file-exists?/quiet p) (extension-ci=? p ".opus"))) - -(define (manager-temp-path? p) - (define-values (_base name _dir?) (split-path p)) - (and (path? name) - (regexp-match? #rx"^\\..*\\.tmp-[0-9.]+\\.(flac|opus)$" (path->string name)))) - -(define (regular-file-path? p) - (file-exists?/quiet p)) - -(define (directory-list/quiet dir) - (with-handlers ([exn:fail? (lambda (_) '())]) - (directory-list dir #:build? #t))) - -(define (directory-exists?/quiet p) - (with-handlers ([exn:fail? (lambda (_) #f)]) - (directory-exists? p))) - -(define (sort-paths paths) - (sort paths stringstring)) - -(define (directory-file-paths base-dir) - ;; Tolerant recursive walker for Windows UNC/long-path trees. A single - ;; vanished or unreadable entry is skipped instead of aborting the scan. - (define root (filesystem-path base-dir)) - (let loop ([dir root] [acc '()]) - (for/fold ([acc acc]) ([p (in-list (sort-paths (directory-list/quiet dir)))]) - (cond [(directory-exists?/quiet p) (loop p acc)] - [(and (file-exists?/quiet p) (not (manager-temp-path? p))) (cons p acc)] - [else acc])))) - -(define (replace-path-extension p ext) - (let-values ([(base name dir?) (split-path p)]) - (unless (path? name) (error 'replace-path-extension "path has no file name: ~a" p)) - (build-path base (path-replace-extension name ext)))) - -(define (ensure-parent-directory! p) - (define-values (base name dir?) (split-path p)) - (when (path? base) (make-directory* base))) - -(define (alist-ref/default a k [default #f]) - (define e (assoc k a)) - (if e (cdr e) default)) - -(define (alist-set a k v) - (cons (cons k v) (filter (lambda (e) (not (equal? (car e) k))) a))) +(define (not-hidden? path) + (not (hidden-path? path)))