Full conversion done
This commit is contained in:
+112
-18
@@ -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)))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(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))))
|
||||
)
|
||||
|
||||
|
||||
@@ -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)
|
||||
)
|
||||
)
|
||||
)
|
||||
+12
-17
@@ -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))
|
||||
|
||||
+22
-143
@@ -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 <email>"))
|
||||
(to (get 'to "configure to address as name <email>"))
|
||||
(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: <addr>" and
|
||||
;; "RCPT TO: <addr>". 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:<addr>" / "RCPT TO:<addr>".
|
||||
(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 ""))))
|
||||
|
||||
@@ -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)
|
||||
)
|
||||
)
|
||||
)
|
||||
+42
-153
@@ -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 string<? #:key path->string))
|
||||
|
||||
(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)))
|
||||
|
||||
Reference in New Issue
Block a user