diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2018-07-03 00:26:59 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2018-07-03 00:39:11 +0200 |
| commit | 3dbf331942f11ee888ccbf849cacdd3a0ab971cd (patch) | |
| tree | e14b075fe4e103288d7536123bcc4c83f1bf1f3a | |
| parent | af2f8ae5f14d272d341148764d256792d8ef06aa (diff) | |
deduplication: Place link files under /gnu/store/.links.
Previously they'd always be placed next to TO-REPLACE, which would lead
to EPERM in some cases.
* guix/store/deduplication.scm (replace-with-link): Add #:swap-directory
parameter and honor it. Add call to 'make-file-writable'. Catch
'system-error' around 'rename-file'.
(deduplicate): Pass #:swap-directory and remove uses of
'false-if-system-error'.
* tests/store-deduplication.scm ("deduplicate"): Add 'chmod' call.
| -rw-r--r-- | guix/store/deduplication.scm | 28 | ||||
| -rw-r--r-- | tests/store-deduplication.scm | 4 |
2 files changed, 23 insertions, 9 deletions
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index b1cd8873aea..b97719d4bf6 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm | |||
| @@ -94,11 +94,21 @@ LINK-PREFIX." | |||
| 94 | ;; things link to this" (EMLINK), "this link already exists" (EEXIST), and | 94 | ;; things link to this" (EMLINK), "this link already exists" (EEXIST), and |
| 95 | ;; "can't fit more stuff in this directory" (ENOSPC). | 95 | ;; "can't fit more stuff in this directory" (ENOSPC). |
| 96 | 96 | ||
| 97 | (define (replace-with-link target to-replace) | 97 | (define* (replace-with-link target to-replace |
| 98 | "Atomically replace the file TO-REPLACE with a link to TARGET. Note: TARGET | 98 | #:key (swap-directory (dirname target))) |
| 99 | and TO-REPLACE must be on the same file system." | 99 | "Atomically replace the file TO-REPLACE with a link to TARGET. Use |
| 100 | (let ((temp-link (get-temp-link target (dirname to-replace)))) | 100 | SWAP-DIRECTORY as the directory to store temporary hard links. |
| 101 | (rename-file temp-link to-replace))) | 101 | |
| 102 | Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." | ||
| 103 | (let ((temp-link (get-temp-link target swap-directory))) | ||
| 104 | (make-file-writable (dirname to-replace)) | ||
| 105 | (catch 'system-error | ||
| 106 | (lambda () | ||
| 107 | (rename-file temp-link to-replace)) | ||
| 108 | (lambda args | ||
| 109 | (delete-file temp-link) | ||
| 110 | (unless (= EMLINK (system-error-errno args)) | ||
| 111 | (apply throw args)))))) | ||
| 102 | 112 | ||
| 103 | (define-syntax-rule (false-if-system-error (errors ...) exp ...) | 113 | (define-syntax-rule (false-if-system-error (errors ...) exp ...) |
| 104 | "Given ERRORS, a list of system error codes to ignore, evaluates EXP... and | 114 | "Given ERRORS, a list of system error codes to ignore, evaluates EXP... and |
| @@ -131,8 +141,8 @@ under STORE." | |||
| 131 | #:store store)))) | 141 | #:store store)))) |
| 132 | (scandir path)) | 142 | (scandir path)) |
| 133 | (if (file-exists? link-file) | 143 | (if (file-exists? link-file) |
| 134 | (false-if-system-error (EMLINK) | 144 | (replace-with-link link-file path |
| 135 | (replace-with-link link-file path)) | 145 | #:swap-directory links-directory) |
| 136 | (catch 'system-error | 146 | (catch 'system-error |
| 137 | (lambda () | 147 | (lambda () |
| 138 | (link path link-file)) | 148 | (link path link-file)) |
| @@ -141,8 +151,8 @@ under STORE." | |||
| 141 | (cond ((= errno EEXIST) | 151 | (cond ((= errno EEXIST) |
| 142 | ;; Someone else put an entry for PATH in | 152 | ;; Someone else put an entry for PATH in |
| 143 | ;; LINKS-DIRECTORY before we could. Let's use it. | 153 | ;; LINKS-DIRECTORY before we could. Let's use it. |
| 144 | (false-if-system-error (EMLINK) | 154 | (replace-with-link path link-file |
| 145 | (replace-with-link path link-file))) | 155 | #:swap-directory links-directory)) |
| 146 | ((= errno ENOSPC) | 156 | ((= errno ENOSPC) |
| 147 | ;; There's not enough room in the directory index for | 157 | ;; There's not enough room in the directory index for |
| 148 | ;; more entries in .links, but that's fine: we can | 158 | ;; more entries in .links, but that's fine: we can |
diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm index 23617231994..4ca2ec0f61e 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm | |||
| @@ -47,6 +47,10 @@ | |||
| 47 | (lambda (port) | 47 | (lambda (port) |
| 48 | (put-bytevector port data)))) | 48 | (put-bytevector port data)))) |
| 49 | identical) | 49 | identical) |
| 50 | ;; Make the parent of IDENTICAL read-only. This should not prevent | ||
| 51 | ;; deduplication for inserting its hard link. | ||
| 52 | (chmod (dirname (second identical)) #o544) | ||
| 53 | |||
| 50 | (call-with-output-file unique | 54 | (call-with-output-file unique |
| 51 | (lambda (port) | 55 | (lambda (port) |
| 52 | (put-bytevector port (string->utf8 "This is unique.")))) | 56 | (put-bytevector port (string->utf8 "This is unique.")))) |
