Genormaliseerde paden in keystore.

2026-06-09 15:25:27 +02:00
parent ce5c4d6de5
commit 5263ebee71
7 changed files with 170 additions and 47 deletions
@@ -14,7 +14,9 @@ Both managers use the same administration files in the source tree:
 - `.flac-48khz-manager.log`: log file

 The `flac2opus` state uses its own key prefix in `.music-info.db`, so it can share
-the same database with the 48 kHz manager without mixing state entries.
+the same database with the 48 kHz manager without mixing state entries. State
+keys use only normalized paths relative to the configured source/base directory:
+absolute mount points are not stored, and path separators are always `/`.

 ## FLAC 48 kHz manager

@@ -39,12 +39,16 @@
               [else (format "mtime-size:~a:~a" (file-size path) (file-or-directory-modify-seconds path))])]
        [else (format "mtime-size:~a:~a" (file-size path) (file-or-directory-modify-seconds path))]))

+(define (state-target-relpath old)
+  (define v (and old (alist-ref/default old 'target-relpath #f)))
+  (and v (normalize-relpath-string v)))
+
 (define (same-quick-state? old path target-path target-relpath kbps)
  (and old
       (file-exists? target-path)
       (equal? (alist-ref/default old 'size #f) (file-size path))
       (equal? (alist-ref/default old 'mtime #f) (file-or-directory-modify-seconds path))
-       (equal? (alist-ref/default old 'target-relpath #f) target-relpath)
+       (equal? (state-target-relpath old) target-relpath)
       (equal? (alist-ref/default old 'kbps #f) kbps)
       (not (equal? (alist-ref/default old 'status #f) 'error))))

@@ -52,36 +56,36 @@
  (and old
       (file-exists? target-path)
       (equal? (alist-ref/default old 'signature #f) signature)
-       (equal? (alist-ref/default old 'target-relpath #f) target-relpath)
+       (equal? (state-target-relpath old) target-relpath)
       (equal? (alist-ref/default old 'kbps #f) kbps)
       (not (equal? (alist-ref/default old 'status #f) 'error))))

-(define (source-relpath base-dir path)
-  (find-relative-path (filesystem-path base-dir) (filesystem-path path)))
-
 (define (source-relpath-string base-dir path)
-  (path->string (source-relpath base-dir path)))
+  (normalized-relpath-string base-dir path))

-(define (flac-extension-path? p)
-  (let-values ([(base name dir?) (split-path p)])
+(define (flac-extension-relpath? relpath)
+  (let-values ([(base name dir?) (split-path (string->path relpath))])
    (and (path? name)
         (let ([ext (path-get-extension name)])
           (and ext (string-ci=? (bytes->string/utf-8 ext) ".flac"))))))

-(define (target-relpath-for rel)
-  (if (flac-extension-path? rel) (replace-path-extension rel #".opus") rel))
+(define (target-relpath-for relpath)
+  (if (flac-extension-relpath? relpath)
+      (normalize-relpath-string
+       (path->string (replace-path-extension (string->path relpath) #".opus")))
+      relpath))

-(define (target-path-for target-dir target-rel)
-  (build-path target-dir target-rel))
+(define (target-path-for target-dir target-relpath)
+  (build-path target-dir (normalized-relpath->path target-relpath)))

 (define (delete-file/quiet path)
  (with-handlers ([exn:fail? (lambda (_) #f)])
    (and (file-exists? path) (delete-file path) #t)))

 (define (delete-old-target-if-needed! target-dir old new-target-relpath)
-  (define old-target-relpath (and old (alist-ref/default old 'target-relpath #f)))
+  (define old-target-relpath (state-target-relpath old))
  (when (and old-target-relpath (not (equal? old-target-relpath new-target-relpath)))
-    (define old-target (build-path target-dir old-target-relpath))
+    (define old-target (target-path-for target-dir old-target-relpath))
    (when (delete-file/quiet old-target)
      (info-alm "removed obsolete target: ~a" old-target-relpath))))

@@ -99,9 +103,8 @@
                (cons 'kbps kbps))
          extra))

-(define (process-one-source-file ks config source-dir target-dir path rel relpath target-rel target-relpath
-                                 kbps convert-proc summary errors)
-  (define target-path (target-path-for target-dir target-rel))
+(define (process-one-source-file ks config target-dir path relpath target-relpath kbps convert-proc summary errors)
+  (define target-path (target-path-for target-dir target-relpath))
  (define old (flac2opus-state-get-file ks relpath #f))
  (cond [(same-quick-state? old path target-path target-relpath kbps)
         (info-alm "unchanged: ~a" relpath)
@@ -155,9 +158,9 @@
    (if (hash-ref current old-rel #f)
        s
        (let* ([old (flac2opus-state-get-file ks old-rel #f)]
-               [target-relpath (and old (alist-ref/default old 'target-relpath #f))])
+               [target-relpath (state-target-relpath old)])
          (when target-relpath
-            (define target-path (build-path target-dir target-relpath))
+            (define target-path (target-path-for target-dir target-relpath))
            (when (delete-file/quiet target-path)
              (info-alm "removed target for deleted source: ~a" target-relpath)))
          (info-alm "removed from flac2opus state: ~a" old-rel)
@@ -188,19 +191,14 @@
  (info-alm "opus bitrate: ~a kbps" kbps)
  (define ks (open-flac2opus-state (manager-config-state-file config)))
  (define files (find-source-files source-dir))
-  (define rels (map (lambda (p) (source-relpath source-dir p)) files))
-  (define relpaths (map path->string rels))
-  (define target-rels (map target-relpath-for rels))
-  (define target-relpaths (map path->string target-rels))
+  (define relpaths (map (lambda (p) (source-relpath-string source-dir p)) files))
+  (define target-relpaths (map target-relpath-for relpaths))
  (define summary0 (drop-removed! ks target-dir relpaths (make-empty-summary)))
  (define-values (summary errors)
    (for/fold ([summary summary0] [errors '()]) ([p (in-list files)]
-                                                  [rel (in-list rels)]
                                                  [relpath (in-list relpaths)]
-                                                  [target-rel (in-list target-rels)]
                                                  [target-relpath (in-list target-relpaths)])
-      (process-one-source-file ks config source-dir target-dir p rel relpath target-rel target-relpath
-                               kbps convert-proc summary errors)))
+      (process-one-source-file ks config target-dir p relpath target-relpath kbps convert-proc summary errors)))
  (define errors* (reverse errors))
  (with-handlers ([exn:fail? (lambda (e) (err-alm "mail report failed: ~a" (exn-message e)) (void))])
    (maybe-send-report-mail config summary errors*
@@ -1,6 +1,8 @@
 #lang racket/base

-(require keystore)
+(require racket/list
+         keystore
+         "util.rkt")

 (provide open-flac2opus-state
         flac2opus-state-get-file
@@ -14,17 +16,39 @@
  (ks-open state-file))

 (define (file-state-key relpath)
-  (string-append prefix relpath))
+  (string-append prefix (normalize-relpath-string relpath)))
+
+(define (legacy-file-state-key relpath)
+  (string-append prefix (legacy-backslash-relpath-string relpath)))
+
+(define (ks-drop/quiet! ks key)
+  (with-handlers ([exn:fail? (lambda (_) (void))])
+    (ks-drop! ks key)))

 (define (flac2opus-state-get-file ks relpath [default #f])
-  (ks-get ks (file-state-key relpath) default))
+  (define key (file-state-key relpath))
+  (define legacy-key (legacy-file-state-key relpath))
+  (define missing (gensym 'missing))
+  (define value (ks-get ks key missing))
+  (cond [(not (eq? value missing)) value]
+        [(equal? key legacy-key) default]
+        [else (ks-get ks legacy-key default)]))

 (define (flac2opus-state-set-file! ks relpath value)
-  (ks-set! ks (file-state-key relpath) value))
+  (define key (file-state-key relpath))
+  (define legacy-key (legacy-file-state-key relpath))
+  (ks-set! ks key value)
+  (unless (equal? key legacy-key) (ks-drop/quiet! ks legacy-key)))

 (define (flac2opus-state-drop-file! ks relpath)
-  (ks-drop! ks (file-state-key relpath)))
+  (define key (file-state-key relpath))
+  (define legacy-key (legacy-file-state-key relpath))
+  (ks-drop/quiet! ks key)
+  (unless (equal? key legacy-key) (ks-drop/quiet! ks legacy-key)))

 (define (flac2opus-state-known-relpaths ks)
-  (map (lambda (k) (substring k (string-length prefix)))
-       (ks-keys-glob ks (string-append prefix "*"))))
+  (remove-duplicates
+   (map (lambda (k)
+          (normalize-relpath-string (substring k (string-length prefix))))
+        (ks-keys-glob ks (string-append prefix "*")))
+   equal?))
@@ -1,7 +1,8 @@
 #lang racket/base

-(require racket/string
-         keystore)
+(require racket/list
+         keystore
+         "util.rkt")

 (provide open-manager-state
         file-state-key
@@ -16,18 +17,39 @@
  (ks-open state-file))

 (define (file-state-key relpath)
-  (string-append prefix relpath))
+  (string-append prefix (normalize-relpath-string relpath)))
+
+(define (legacy-file-state-key relpath)
+  (string-append prefix (legacy-backslash-relpath-string relpath)))
+
+(define (ks-drop/quiet! ks key)
+  (with-handlers ([exn:fail? (lambda (_) (void))])
+    (ks-drop! ks key)))

 (define (state-get-file ks relpath [default #f])
-  (ks-get ks (file-state-key relpath) default))
+  (define key (file-state-key relpath))
+  (define legacy-key (legacy-file-state-key relpath))
+  (define missing (gensym 'missing))
+  (define value (ks-get ks key missing))
+  (cond [(not (eq? value missing)) value]
+        [(equal? key legacy-key) default]
+        [else (ks-get ks legacy-key default)]))

 (define (state-set-file! ks relpath value)
-  (ks-set! ks (file-state-key relpath) value))
+  (define key (file-state-key relpath))
+  (define legacy-key (legacy-file-state-key relpath))
+  (ks-set! ks key value)
+  (unless (equal? key legacy-key) (ks-drop/quiet! ks legacy-key)))

 (define (state-drop-file! ks relpath)
-  (ks-drop! ks (file-state-key relpath)))
+  (define key (file-state-key relpath))
+  (define legacy-key (legacy-file-state-key relpath))
+  (ks-drop/quiet! ks key)
+  (unless (equal? key legacy-key) (ks-drop/quiet! ks legacy-key)))

 (define (state-known-relpaths ks)
-  (map (lambda (k)
-         (substring k (string-length prefix)))
-       (ks-keys-glob ks (string-append prefix "*"))))
+  (remove-duplicates
+   (map (lambda (k)
+          (normalize-relpath-string (substring k (string-length prefix))))
+        (ks-keys-glob ks (string-append prefix "*")))
+   equal?))
@@ -9,6 +9,10 @@
         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?
@@ -70,8 +74,34 @@
                  [else (raise-argument-error 'filesystem-path "path-string? or path?" p)]))
  (simple-form-path (string->path (windows-extended-path-string s))))

-(define (relpath-string base p)
-  (path->string (find-relative-path (filesystem-path base) (filesystem-path p))))
+(define (replace-char s from to)
+  (list->string
+   (for/list ([ch (in-string s)])
+     (if (char=? ch from) to ch))))
+
+(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)])
@@ -138,7 +138,9 @@ use, the default inspector, fingerprint function and converter are used.}
 Mirrors @racket[source-directory] to @racket[target-directory]. FLAC files are
 converted to Opus at @racket[kbps] kbps; all other regular files are copied.
 The state is stored in the source directory's @filepath{.music-info.db} using a
-separate @tt{flac2opus} prefix.}
+separate @tt{flac2opus} prefix. Keystore keys and stored target paths use
+normalized paths relative to the configured source or target base directory;
+absolute mount points are not stored and separators are always @tt{/}.}

@defproc[(summary->lines [summary list?]) (listof string?)]{
 Formats the summary association list as display lines.}
@@ -0,0 +1,45 @@
+#lang racket/base
+
+(require rackunit
+         racket/file
+         keystore
+         "../private/flac2opus-state.rkt"
+         "../private/state.rkt"
+         "../private/util.rkt")
+
+(check-equal? (normalize-relpath-string "disc1\\track.flac") "disc1/track.flac")
+(check-equal? (legacy-backslash-relpath-string "disc1/track.flac") "disc1\\track.flac")
+(check-exn exn:fail:contract? (lambda () (normalize-relpath-string "../track.flac")))
+(check-exn exn:fail:contract? (lambda () (normalize-relpath-string "/music/track.flac")))
+(check-exn exn:fail:contract? (lambda () (normalize-relpath-string "C:/music/track.flac")))
+
+(define state-file (make-temporary-file "alm-state-~a.db"))
+(define ks (open-manager-state state-file))
+(void (state-set-file! ks "disc1\\track.flac" '((status . normalized))))
+(check-equal? (state-get-file ks "disc1/track.flac") '((status . normalized)))
+(check-equal? (state-known-relpaths ks) '("disc1/track.flac"))
+(check-not-false (member "flac-48khz:file:disc1/track.flac" (ks-keys-glob ks "flac-48khz:file:*")))
+(check-false (member "flac-48khz:file:disc1\\track.flac" (ks-keys-glob ks "flac-48khz:file:*")))
+
+(define legacy-48-key (string-append "flac-48khz:file:" (legacy-backslash-relpath-string "legacy/track.flac")))
+(void (ks-set! ks legacy-48-key '((status . legacy))))
+(check-equal? (state-get-file ks "legacy/track.flac") '((status . legacy)))
+(void (state-set-file! ks "legacy/track.flac" '((status . migrated))))
+(check-equal? (state-get-file ks "legacy/track.flac") '((status . migrated)))
+(check-false (member legacy-48-key (ks-keys-glob ks "flac-48khz:file:*")))
+
+(define ks2 (open-flac2opus-state state-file))
+(void (flac2opus-state-set-file! ks2 "disc1\\track.flac" '((target-relpath . "disc1/track.opus"))))
+(check-equal? (flac2opus-state-get-file ks2 "disc1/track.flac") '((target-relpath . "disc1/track.opus")))
+(check-equal? (flac2opus-state-known-relpaths ks2) '("disc1/track.flac"))
+(check-not-false (member "flac2opus:file:disc1/track.flac" (ks-keys-glob ks2 "flac2opus:file:*")))
+(check-false (member "flac2opus:file:disc1\\track.flac" (ks-keys-glob ks2 "flac2opus:file:*")))
+
+(define legacy-opus-key (string-append "flac2opus:file:" (legacy-backslash-relpath-string "legacy/track.flac")))
+(void (ks-set! ks2 legacy-opus-key '((target-relpath . "legacy\\track.opus"))))
+(check-equal? (flac2opus-state-get-file ks2 "legacy/track.flac") '((target-relpath . "legacy\\track.opus")))
+(void (flac2opus-state-set-file! ks2 "legacy/track.flac" '((target-relpath . "legacy/track.opus"))))
+(check-equal? (flac2opus-state-get-file ks2 "legacy/track.flac") '((target-relpath . "legacy/track.opus")))
+(check-false (member legacy-opus-key (ks-keys-glob ks2 "flac2opus:file:*")))
+
+(delete-file state-file)