path-utils: Check directory still exists & handle Windows length limits

Author: LiberalArtist

gui-lib/framework/private/path-utils.rkt

@@ -1,18 +1,27 @@
 #lang racket/unit
 
 (require "sig.rkt"
+         racket/list
+         openssl/md5
          "../preferences.rkt")
 
 (import)
 (export framework:path-utils^)
 
 ;; preferences initialized in main.rkt
 
+(define (make-getter/ensure-exists pref-sym)
+  (λ ()
+    (let ([maybe-dir (preferences:get pref-sym)])
+      (and maybe-dir
+           (directory-exists? maybe-dir)
+           maybe-dir))))
+
 (define current-backup-dir
-  (preferences:get/set 'path-utils:backup-dir))
+  (make-getter/ensure-exists 'path-utils:backup-dir))
 
 (define current-autosave-dir
-  (preferences:get/set 'path-utils:autosave-dir))
+  (make-getter/ensure-exists 'path-utils:autosave-dir))
 
 ; generate-autosave-name : (or/c #f path-string? path-for-some-system?) -> path?
 (define (generate-autosave-name maybe-old-path)
@@ -62,7 +71,9 @@
       (if (file-exists? new-name)
           (loop (add1 n))
           new-name))))
-  
+
+
+;; generate-backup-name : path? -> path?
 (define (generate-backup-name full-name)
   (define-values (pre-base old-name dir?)
     (split-path full-name))
@@ -92,13 +103,52 @@
 ; we should always use a complete one.
 ; Using simplify-path does that and ensures no 'up or 'same
 ; Using ! is not completely robust, but works well enough for Emacs.
+; Windows has limitations on path lengths. Racket handles MAX_PATH
+; by using "\\?\" paths when necessary, but individual elements must
+; be shorter than lpMaximumComponentLength. If necessary, we avoid
+; this by hashing the path.
 (define (encode-as-path-element base-maybe-relative name)
-  (bytes->path-element
-   (regexp-replace* (case (system-path-convention-type)
-                      [(windows) #rx#"\\\\"]
-                      [else #rx#"/"])
-                    (path->bytes
-                     (simplify-path (build-path base-maybe-relative name)))
-                    #"!")))
+  (define windows?
+    (eq? 'windows (system-path-convention-type)))
+  (define illegal-rx
+    (if windows?
+        #rx#"\\\\"
+        #rx#"/"))
+  (define pth
+    (simplify-path (build-path base-maybe-relative name)))
+  (define legible-name-bytes
+    (let ([elements (explode-path pth)])
+      (apply
+       bytes-append
+       (add-between
+        (cons (regexp-replace* illegal-rx
+                               (path->bytes (car elements))
+                               #"!")
+              (for/list ([elem (in-list (cdr elements))])
+                (regexp-replace* illegal-rx
+                                 (path-element->bytes elem)
+                                 #"!")))
+        #"!"))))
+  (cond
+    [(or (not windows?)
+         (< (bytes-length legible-name-bytes)
+            (lpMaximumComponentLength)))
+     (bytes->path-element legible-name-bytes)]
+    [else
+     (string->path-element
+      (regexp-replace*
+       #rx"\\\\" ; NOT illegal-rx : this is a string regexp
+       (md5 (open-input-bytes (path->bytes pth)))
+       "!"))]))
+
+
+
+;; lpMaximumComponentLength : -> real?
+;; Returns the maximum length of an element of a "\\?\" path on Windows.
+;; For now, assuming 255, but really this should be
+;; "the value returned in the lpMaximumComponentLength parameter
+;; of the GetVolumeInformation function".
+(define (lpMaximumComponentLength)
+  255)