Support saving backup and autosave files in configurable directories

LiberalArtist · LiberalArtist · commit 7376831f9c5a · 2017-11-21T23:18:48.000-06:00
diff --git a/gui-lib/framework/main.rkt b/gui-lib/framework/main.rkt
@@ -535,17 +535,105 @@
   @{Opens a dialog that queries the user about exiting.  Returns the user's
     decision.})
 
- (proc-doc/names
-  path-utils:generate-autosave-name
-  (-> (or/c #f path-string? path-for-some-system?) path?)
-  (filename)
-  @{Generates a name for an autosave file from @racket[filename].})
-
  (proc-doc/names
   path-utils:generate-backup-name
   (path? . -> . path?)
   (filename)
-  @{Generates a name for an backup file from @racket[filename].})
+  @{
+ Generates a path for a backup file based on @racket[filename].
+
+ @index{'path-utils:backup-dir}
+ The value of @racket[(preferences:get 'path-utils:backup-dir)]
+ determines the directory of the resulting path.
+ The value of this preference must be either a path
+ satisfying @racket[complete-path?],
+ in which case it is additionally checked to ensure that the
+ directory exists and is writable,
+ or @racket[#f] (the default).
+ When the preference contains a valid path,
+ the resulting path will use that directory;
+ otherwise, and by default, 
+ the result will use the same directory as @racket[filename].
+ 
+ The final element of the resulting path is derived from @racket[filename].
+ When @racket[(preferences:get 'path-utils:backup-dir)] does not specify
+ a valid directory, the final element of @racket[filename] is
+ used directly as the base for the new element.
+ Otherwise, the base is formed by transforming the complete path to @racket[filename]
+ (resolved, if necessary, relative to @racket[(current-directory)])
+ according to the following @deftech{encoding scheme}:
+ @itemlist[#:style 'ordered
+           @item{A @racket[separator-byte] is selected: @litchar{!} by default,
+             but a list of visually-appealing one-byte characters are
+             tried if @litchar{!} occurs in the complete path to
+             @racket[filename].}
+           @item{Every seperator between path elements is replaced with
+             @racket[separator-byte], as are any other occurances of the
+             reserved separator character (@litchar{\} on Windows or
+             @litchar{/} on Unix or Mac OS), e.g. in the name of the root directory.}
+           @item{A single @racket[separator-byte] is added at the beginning
+             so that the seperator can be unambiguously identified.}
+           @item{If the result of the previous step is excessively long, it
+             may be shortened by replacing some bytes in the middle with
+             @racket[(bytes-append separator-byte #"..." separator-byte)]
+             (i.e. @litchar{!...!} with @litchar{!} as the @racket[separator-byte]).}]
+
+ @margin-note{
+  Currently, "excessively long" is defined as 255 bytes.
+  This is based on @hyperlink["https://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx#maxpath"]{
+   a common value} for the maximum length of an individual element of an extended-length path
+  on Windows, but the limit is currently enforced consistently on all platforms.
+ }
+ 
+ In either case, the final path element is formed from the base
+ in a platform-specific manner:
+ @itemlist[
+ @item{On Unix and Mac OS, a @litchar{~} is added to the end.}
+ @item{On Windows, the extension (in the sense of @racket[path-replace-extension])
+   is replaced with @litchar{.bak}.}]
+ })
+ 
+ (proc-doc/names
+  path-utils:generate-autosave-name
+  (-> (or/c #f path-string? path-for-some-system?) path?)
+  (filename)
+  @{
+ Generates a path for an autosave file based on @racket[filename].
+
+ @index{'path-utils:autosave-dir}
+ The value of @racket[(preferences:get 'path-utils:autosave-dir)]
+ determines the directory of the resulting path
+ in much the same way as @racket[path-utils:generate-backup-name]
+ with @racket['path-utils:backup-dir].
+ When the preference value specifies a directory that exists and
+ is writable, the resulting path will use that directory.
+ Otherwise, and by default, the
+ result will use the same directory as @racket[filename]
+ (or, when @racket[filename] is @racket[#f], the directory determined by
+ @racket[(find-system-path 'doc-dir)]).
+
+ When @racket[filename] is @racket[#f], the final element of the
+ resulting path will be an automatically-generated unique name.
+ 
+ Otherwise, the final path element will be derived from @racket[filename].
+ When @racket[(preferences:get 'path-utils:autosave-dir)] does not return
+ a valid directory, the last element of @racket[filename] will be
+ used directly as the base for the new element.
+ When a valid autosave directory is specified, the base will be
+ the complete path to @racket[filename],
+ transformed according to the same @tech{encoding scheme} as
+ with @racket[path-utils:generate-backup-name].
+ In either case, the final path element is formed from the base
+ in a platform-specific manner:
+ @itemlist[
+ @item{On Unix and Mac OS, a @litchar{#} is added to the start
+   and end, then a number is added after the
+   ending @litchar{#}, and then one more @litchar{#} is appended
+   after the number.
+   The number is selected to make the autosave filename unique.}
+ @item{On Windows, the file’s extension (in the sense of @racket[path-replace-extension])
+   is replaced with a number to make the autosave filename unique.}
+ ]})
 
  (parameter-doc
   finder:dialog-parent-parameter
diff --git a/gui-lib/framework/private/main.rkt b/gui-lib/framework/private/main.rkt
@@ -599,6 +599,32 @@
   (update-style-list 
    (color-prefs:lookup-in-color-scheme 'framework:misspelled-text-color)))
 
+;; for path-utils
+
+(define (valid-maybe-path-value? v)
+  (or (not v)
+      (and (path? v)
+           (complete-path? v)
+           (directory-exists? v)
+           (memq 'write (file-or-directory-permissions v)))))
+
+(define (marshall:maybe-path->bytes v)
+  (and (path? v) (path->bytes v)))
+
+(define (unmarshall:maybe-bytes->path v)
+  (with-handlers ([exn:fail? (λ (e) #f)])
+    (and v (bytes->path v))))
+
+(define (initialize-backup/autosave-preference sym)
+  (preferences:set-default sym #f valid-maybe-path-value?)
+  (preferences:set-un/marshall sym
+                               marshall:maybe-path->bytes
+                               unmarshall:maybe-bytes->path))
+
+(initialize-backup/autosave-preference 'path-utils:backup-dir)
+
+(initialize-backup/autosave-preference 'path-utils:autosave-dir)
+
 ;; groups
 
 (preferences:set-default 'framework:exit-when-no-frames #t boolean?)
diff --git a/gui-lib/framework/private/path-utils.rkt b/gui-lib/framework/private/path-utils.rkt
@@ -1,26 +1,58 @@
 #lang scheme/unit
-  (require "sig.rkt")
+  (require "sig.rkt"
+           racket/list
+           "../preferences.rkt")
   
   (import)
   (export framework:path-utils^)
-  
-  (define (generate-autosave-name name)
-    (let-values ([(base name dir?)
-                  (if name
-                      (split-path name)
-                      (values (find-system-path 'doc-dir)
-                              (bytes->path-element #"mredauto")
-                              #f))])
-      (let* ([base (if (path? base)
-                       base
-                       (current-directory))]
-             [path (if (relative-path? base)
-                       (build-path (current-directory) base)
-                       base)])
+
+;; 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)
+           (memq 'write (file-or-directory-permissions maybe-dir))
+           maybe-dir))))
+
+(define current-backup-dir
+  (make-getter/ensure-exists 'path-utils:backup-dir))
+
+(define current-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)
+     (cond
+       [maybe-old-path
+        (let*-values ([(base name dir?) (split-path maybe-old-path)]
+                      [(base) (cond
+                                [(not (path? base))
+                                 (current-directory)]
+                                [(relative-path? base)
+                                 (build-path (current-directory) base)]
+                                [else
+                                 base])])
+          (cond
+            [(current-autosave-dir)
+             =>
+             (λ (dir)
+               (make-unique-autosave-name dir (encode-as-path-element base name)))]
+            [else
+             (make-unique-autosave-name base name)]))]
+       [else
+        (make-unique-autosave-name (or (current-autosave-dir)
+                                       (find-system-path 'doc-dir))
+                                   (bytes->path-element #"mredauto"))]))
+
+
+      ; make-unique-autosave-name : dir-path path-element -> path?
+      (define (make-unique-autosave-name dir name)
         (let loop ([n 1])
           (let* ([numb (string->bytes/utf-8 (number->string n))]
                  [new-name
-                  (build-path path
+                  (build-path dir
                               (if (eq? (system-type) 'windows)
                                   (bytes->path-element
                                    (bytes-append (regexp-replace #rx#"\\..*$" 
@@ -36,22 +68,115 @@
                                                  #"#"))))])
             (if (file-exists? new-name)
                 (loop (add1 n))
-                new-name))))))
-  
+                new-name))))
+
+  ;; generate-backup-name : path? -> path?
   (define (generate-backup-name full-name)
     (let-values ([(pre-base name dir?) (split-path full-name)])
       (let ([base (if (path? pre-base)
                       pre-base
                       (current-directory))])
-        (let ([name-bytes (path-element->bytes name)])
-          (cond
-            [(and (eq? (system-type) 'windows)
-                  (regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
-             =>
-             (λ (m)
-               (build-path base (bytes->path-element (bytes-append (cadr m) #".bak"))))]
-            [(eq? (system-type) 'windows)
-             (build-path base (bytes->path-element (bytes-append name-bytes #".bak")))]
-            [else
-             (build-path base (bytes->path-element (bytes-append name-bytes #"~")))])))))
+        (define name-element
+           (let ([name-bytes (path-element->bytes name)])
+             (bytes->path-element
+              (cond
+                [(and (eq? (system-type) 'windows)
+                      (regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
+                 =>
+                 (λ (m)
+                   (bytes-append (cadr m) #".bak"))]
+                [(eq? (system-type) 'windows)
+                 (bytes-append name-bytes #".bak")]
+                [else
+                 (bytes-append name-bytes #"~")]))))
+         (cond
+           [(current-backup-dir)
+            =>
+            (λ (dir)
+              (build-path dir (encode-as-path-element base name-element)))]
+           [else
+            (build-path base name-element)]))))
+ 
+ 
+ 
+(define candidate-separators
+  `(#"!" #"%" #"_" #"|" #":" #">" #"^" #"$" #"@" #"*" #"?"))
+
+(define separator-regexps
+  (map (compose1 byte-regexp regexp-quote) candidate-separators))
+
+; encode-as-path-element : dir-path path-element -> path-element
+; N.B. generate-backup-name may supply a relative directory, but
+; we should always use a complete one.
+; That is handled by simplify+explode-path->bytes.
+; Windows has limitations on path lengths. Racket handles MAX_PATH
+; by using "\\?\" paths when necessary, but individual elements must
+; be shorter than lpMaximumComponentLength.
+; We respect this limit (on all platforms, for consistency)
+; by replacing some bytes from the middle if necessary.
+(define (encode-as-path-element base-maybe-relative name)
+  (define illegal-rx
+    (case (system-path-convention-type)
+      [(windows) #rx#"\\\\"]
+      [else #rx#"/"]))
+  (define l-bytes
+    (simplify+explode-path->bytes (build-path base-maybe-relative name)))
+  (define separator-byte
+    (or (let ([all-components (apply bytes-append l-bytes)])
+          (for/first ([sep (in-list candidate-separators)]
+                      [rx (in-list separator-regexps)]
+                      #:unless (regexp-match? rx all-components))
+            sep))
+        #"!"))
+  (define legible-name-bytes
+    (apply
+     bytes-append
+     separator-byte
+     (add-between
+      (for/list ([elem (in-list l-bytes)])
+        (regexp-replace* illegal-rx elem separator-byte))
+      separator-byte)))
+  (define num-legible-bytes
+    (bytes-length legible-name-bytes))
+  (bytes->path-element
+   (cond
+     [(< num-legible-bytes
+         (lpMaximumComponentLength))
+      legible-name-bytes]
+     [else
+      (define replacement
+        (bytes-append separator-byte #"..." separator-byte))
+      (define num-excess-bytes
+        (+ (- num-legible-bytes
+              (lpMaximumComponentLength))
+           5 ; extra margin of safety
+           (bytes-length replacement)))
+      (define num-bytes-to-keep-per-side
+        (floor (/ (- num-legible-bytes num-excess-bytes)
+                  2)))
+      (bytes-append
+       (subbytes legible-name-bytes 0 num-bytes-to-keep-per-side)
+       replacement
+       (subbytes legible-name-bytes (- num-legible-bytes
+                                       num-bytes-to-keep-per-side)))])))
+     
+
+;; simplify+explode-path->bytes : path? -> (listof bytes?)
+;; Useful because path-element->bytes doesn't work on root paths.
+;; Using simplify-path ensures no 'up or 'same.
+(define (simplify+explode-path->bytes pth)
+  (define elems
+    (explode-path (simplify-path pth)))
+  (cons (path->bytes (car elems))
+        (map path-element->bytes (cdr elems))))
+
+;; 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".
+;; See https://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx#maxpath
+(define (lpMaximumComponentLength)
+  255)
+
 
diff --git a/gui-test/framework/tests/README b/gui-test/framework/tests/README
@@ -41,6 +41,10 @@ signal failures when there aren't any.
   | This tests that preferences are saved and restored correctly, both
   | immediately and across reboots of gracket.
 
+- path-utils: path-utils.rkt -- runs directly via raco test
+
+  | This tests that paths for autosave and backup files are
+  | generated correctly and respond correctly to preferences.
 
 - individual object tests:
 
diff --git a/gui-test/framework/tests/path-utils.rkt b/gui-test/framework/tests/path-utils.rkt
