|
8 | 8 | generate-backup-name]) |
9 | 9 | racket/file |
10 | 10 | racket/contract/base |
| 11 | + racket/sequence |
| 12 | + racket/list |
11 | 13 | framework/preferences) |
12 | 14 |
|
13 | | -;; For uniform comparisons, all tests use simplified paths normalized |
14 | | -;; with path->directory-path when applicable. |
| 15 | +;; For uniform comparisons with equal?, all tests use simplified paths |
| 16 | +;; normalized with path->directory-path when applicable. |
15 | 17 |
|
| 18 | + |
| 19 | +;; path-base: path? -> path? |
| 20 | +;; Returns the directory of the input path (i.e. removes the final element), |
| 21 | +;; normalized for comparison with equal? |
16 | 22 | (define (path-base pth) |
17 | 23 | (define-values (base name dir?) |
18 | 24 | (split-path pth)) |
19 | 25 | (path->directory-path base)) |
20 | 26 |
|
| 27 | + |
| 28 | +;; remove-all-write-permissions: path? -> any |
| 29 | +;; Modifies the permissions of the given file/directory so no one can write to it |
| 30 | +(define (remove-all-write-permissions pth) |
| 31 | + (define old-permissions-bits |
| 32 | + (file-or-directory-permissions pth 'bits)) |
| 33 | + (file-or-directory-permissions |
| 34 | + pth |
| 35 | + (bitwise-and old-permissions-bits |
| 36 | + (bitwise-not user-write-bit) |
| 37 | + (bitwise-not group-write-bit) |
| 38 | + (bitwise-not other-write-bit)))) |
| 39 | + |
| 40 | + |
| 41 | +;; call-with-preference-not-writable: procedure? (-> any) -> any |
| 42 | +;; Takes a procedure produced with preferences:get/set and a thunk. |
| 43 | +;; Calls the thunk in a context where: |
| 44 | +;; (a) it ensures the preference will have the value it did |
| 45 | +;; when call-with-preference-not-writable was called, which |
| 46 | +;; is assumed to be a path, and |
| 47 | +;; (b) it removes all write permissions from the directory |
| 48 | +;; specified by the preference before calling the thunk. |
| 49 | +;; After the thunk returns (or control escapes), call-with-preference-not-writable:: |
| 50 | +;; (a) restores the directory's original permissions and |
| 51 | +;; (b) restores the preference to its initial value. |
| 52 | +(define (call-with-preference-not-writable get/set-proc thunk) |
| 53 | + (define pth |
| 54 | + (get/set-proc)) |
| 55 | + (define old-permissions-bits |
| 56 | + (file-or-directory-permissions pth 'bits)) |
| 57 | + (dynamic-wind |
| 58 | + (λ () |
| 59 | + (get/set-proc pth) |
| 60 | + (remove-all-write-permissions pth)) |
| 61 | + thunk |
| 62 | + (λ () |
| 63 | + (file-or-directory-permissions pth old-permissions-bits) |
| 64 | + (get/set-proc pth)))) |
| 65 | + |
| 66 | + |
| 67 | +;; See framework/private/path-utils for rationale |
| 68 | +(define max-path-element-length |
| 69 | + 255) |
| 70 | + |
| 71 | + |
| 72 | +; |
| 73 | +; |
| 74 | +; |
| 75 | +; |
| 76 | +; ;; ;; |
| 77 | +; ;; ;; |
| 78 | +; ;;;;;;; ;;; ;; ;;;;;;; ;; |
| 79 | +; ;; ;; ; ;; ; ;; ;; ; |
| 80 | +; ;; ; ; ; ;; ; |
| 81 | +; ;; ;;;;;;;; ;; ;; ;; |
| 82 | +; ;; ; ;; ;; ;; |
| 83 | +; ; ;; ; ; ; ; ; ; |
| 84 | +; ;;; ;;; ;;; ;;; ;;; |
| 85 | +; |
| 86 | +; |
| 87 | +; |
| 88 | +; |
21 | 89 | (let ([the-prefs-table (make-hash)]) |
22 | 90 | (parameterize ([preferences:low-level-put-preferences |
23 | 91 | (λ (syms vals) |
|
42 | 110 | (build-path current-dir "somewhere" elem)) |
43 | 111 | (define dir-of-complete |
44 | 112 | (path-base complete)) |
| 113 | + (define too-long-pth |
| 114 | + (build-path |
| 115 | + current-dir |
| 116 | + (bytes->path-element |
| 117 | + (bytes-append |
| 118 | + (list->bytes |
| 119 | + (for/list ([i (in-range (+ 10 max-path-element-length))] |
| 120 | + [b (in-cycle |
| 121 | + (sequence-filter (compose1 (λ (c) |
| 122 | + (or (char-alphabetic? c) |
| 123 | + (char-numeric? c))) |
| 124 | + integer->char) |
| 125 | + (in-range 48 123)))]) |
| 126 | + b)) |
| 127 | + #".rkt")))) |
45 | 128 | ;; Tests with #f for directories |
46 | 129 | (current-backup-dir #f) |
47 | 130 | (current-autosave-dir #f) |
|
96 | 179 | (equal? (simplify-path (generate-autosave-name complete)) |
97 | 180 | (simplify-path (generate-autosave-name clashing-name))) |
98 | 181 | "files with the same name in different directories should not collide") |
| 182 | + ; long path element |
| 183 | + (check-not-false |
| 184 | + (< (bytes-length (path-element->bytes |
| 185 | + (last (explode-path (generate-autosave-name |
| 186 | + too-long-pth))))) |
| 187 | + max-path-element-length) |
| 188 | + "excessively long elements should be shortened") |
| 189 | + ; write permission |
| 190 | + (call-with-preference-not-writable |
| 191 | + current-autosave-dir |
| 192 | + (λ () |
| 193 | + (test-case |
| 194 | + "autosave dir not writable" |
| 195 | + (check-false (memq 'write (file-or-directory-permissions autosave-dir)) |
| 196 | + "autosave dir should have been made non-writable") |
| 197 | + (check-equal? (path-base (generate-autosave-name complete)) |
| 198 | + dir-of-complete |
| 199 | + "should fall back when autosave dir not writable")))) |
99 | 200 | ; delete |
100 | 201 | (delete-directory autosave-dir) |
101 | 202 | (check-equal? (path-base (generate-autosave-name complete)) |
|
112 | 213 | (equal? (simplify-path (generate-backup-name complete)) |
113 | 214 | (simplify-path (generate-backup-name clashing-name))) |
114 | 215 | "files with the same name in different directories should not collide") |
| 216 | + ; long path element |
| 217 | + (check-not-false |
| 218 | + (< (bytes-length (path-element->bytes |
| 219 | + (last (explode-path (generate-backup-name |
| 220 | + too-long-pth))))) |
| 221 | + max-path-element-length) |
| 222 | + "excessively long elements should be shortened") |
| 223 | + ; write permission |
| 224 | + (call-with-preference-not-writable |
| 225 | + current-backup-dir |
| 226 | + (λ () |
| 227 | + (test-case |
| 228 | + "backup dir not writable" |
| 229 | + (check-false (memq 'write (file-or-directory-permissions backup-dir)) |
| 230 | + "backup dir should have been made non-writable") |
| 231 | + (check-equal? (path-base (generate-backup-name complete)) |
| 232 | + dir-of-complete |
| 233 | + "should fall back when backup dir not writable")))) |
115 | 234 | ; delete |
116 | 235 | (delete-directory backup-dir) |
117 | 236 | (check-equal? (path-base (generate-backup-name complete)) |
|
0 commit comments