check filenames

private/file-walker.rkt

@@ -6,6 +6,7 @@
          racket/path
          "store.rkt"
          "log.rkt"
+         "util.rkt"
          file/glob)
 
 (provide make-file-walker
@@ -37,30 +38,43 @@
       (let ((path (gen)))
         (if (void? path)
             (values #f #f #f)
-            (let* ((str-path (path->string path))
+            (let* ((bd (basedir path))
-                   (ext* (path-get-extension path))
+                   (bn (format "~a" (basename path)))
-                   (ext (string->symbol
+                   (nbn (clean-os-basename bn))
-                         (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 (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))
                    )
-              (filter-func base-path path info)))
+
+              (unless (string=? bn nbn)
+                (with-handlers ([exn? (λ (e)
+                                         (warn-am "Cannot rename dirty filename: ~a" nbn))])
+                  (rename-file-or-directory (build-path bd bn)
+                                            (build-path bn nbn) #f)
+                  (set! path (build-path bd nbn))
+                  ))
+              
+              (let* ((str-path (path->string path))
+                     (ext* (path-get-extension path))
+                     (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 (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))
+                     )
+                (filter-func base-path path info))))
         )
       )
     )
@@ -168,7 +182,9 @@
                                  (let-values (((base-path* path* info*) (file-admin base-path path info)))
                                    (values base-path* path* info*)))))
          (deleted #f))
+    
     (init-db-sweep)
+    
     (letrec ((f (λ ()
                   (if (list? deleted)
                       (if (null? deleted)
@@ -201,3 +217,26 @@
           (step-func base-path path info))))
   )
 
+
+(define (clean-os-basename name)
+  (let* ((s0 (format "~a" name))
+         (s1 (list->string
+              (for/list ((ch (in-string s0)))
+                (if (or (< (char->integer ch) 32)
+                        (memq ch '(#\< #\> #\: #\" #\/ #\\ #\| #\? #\*)))
+                    #\-
+                    ch))))
+         (s2 (regexp-replace* #px"\\s+" s1 " "))
+         (s3 (regexp-replace* #px"[- ]+" s2 " "))
+         (s4 (string-trim s3 " .-_"))
+         (device-name (let* ((parts (string-split s4 "."))
+                             (first-part (if (null? parts) s4 (car parts))))
+                        first-part))
+         (reserved? (regexp-match?
+                     #px"(?i:^(con|prn|aux|nul|com[1-9]|lpt[1-9])$)"
+                     device-name))
+         (s5 (cond
+               ((string=? s4 "") "_")
+               (reserved? (string-append "_" s4))
+               (else s4))))
+    s5))