deduplication: Use 'dynamic-wind' when changing permissions of the parent.
Suggested by Caleb Ristvedt <caleb.ristvedt@cune.org>. * guix/store/deduplication.scm (call-with-writable-file): New procedure. (with-writable-file): New macro. (replace-with-link): Use it.master
parent
b930f0ba21
commit
d52e16d3b6
|
@ -37,6 +37,7 @@
|
||||||
(eval . (put 'with-file-lock 'scheme-indent-function 1))
|
(eval . (put 'with-file-lock 'scheme-indent-function 1))
|
||||||
(eval . (put 'with-file-lock/no-wait 'scheme-indent-function 1))
|
(eval . (put 'with-file-lock/no-wait 'scheme-indent-function 1))
|
||||||
(eval . (put 'with-profile-lock 'scheme-indent-function 1))
|
(eval . (put 'with-profile-lock 'scheme-indent-function 1))
|
||||||
|
(eval . (put 'with-writable-file 'scheme-indent-function 1))
|
||||||
|
|
||||||
(eval . (put 'package 'scheme-indent-function 0))
|
(eval . (put 'package 'scheme-indent-function 0))
|
||||||
(eval . (put 'origin 'scheme-indent-function 0))
|
(eval . (put 'origin 'scheme-indent-function 0))
|
||||||
|
|
|
@ -94,6 +94,20 @@ LINK-PREFIX."
|
||||||
(try (tempname-in link-prefix))
|
(try (tempname-in link-prefix))
|
||||||
(apply throw args))))))
|
(apply throw args))))))
|
||||||
|
|
||||||
|
(define (call-with-writable-file file thunk)
|
||||||
|
(let ((stat (lstat file)))
|
||||||
|
(dynamic-wind
|
||||||
|
(lambda ()
|
||||||
|
(make-file-writable file))
|
||||||
|
thunk
|
||||||
|
(lambda ()
|
||||||
|
(set-file-time file stat)
|
||||||
|
(chmod file (stat:mode stat))))))
|
||||||
|
|
||||||
|
(define-syntax-rule (with-writable-file file exp ...)
|
||||||
|
"Make FILE writable for the dynamic extent of EXP..."
|
||||||
|
(call-with-writable-file file (lambda () exp ...)))
|
||||||
|
|
||||||
;; There are 3 main kinds of errors we can get from hardlinking: "Too many
|
;; There are 3 main kinds of errors we can get from hardlinking: "Too many
|
||||||
;; things link to this" (EMLINK), "this link already exists" (EEXIST), and
|
;; things link to this" (EMLINK), "this link already exists" (EEXIST), and
|
||||||
;; "can't fit more stuff in this directory" (ENOSPC).
|
;; "can't fit more stuff in this directory" (ENOSPC).
|
||||||
|
@ -120,20 +134,14 @@ Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
|
||||||
;; If we couldn't create TEMP-LINK, that's OK: just don't do the
|
;; If we couldn't create TEMP-LINK, that's OK: just don't do the
|
||||||
;; replacement, which means TO-REPLACE won't be deduplicated.
|
;; replacement, which means TO-REPLACE won't be deduplicated.
|
||||||
(when temp-link
|
(when temp-link
|
||||||
(let* ((parent (dirname to-replace))
|
(with-writable-file (dirname to-replace)
|
||||||
(stat (stat parent)))
|
|
||||||
(make-file-writable parent)
|
|
||||||
(catch 'system-error
|
(catch 'system-error
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(rename-file temp-link to-replace))
|
(rename-file temp-link to-replace))
|
||||||
(lambda args
|
(lambda args
|
||||||
(delete-file temp-link)
|
(delete-file temp-link)
|
||||||
(unless (= EMLINK (system-error-errno args))
|
(unless (= EMLINK (system-error-errno args))
|
||||||
(apply throw args))))
|
(apply throw args)))))))
|
||||||
|
|
||||||
;; Restore PARENT's mtime and permissions.
|
|
||||||
(set-file-time parent stat)
|
|
||||||
(chmod parent (stat:mode stat)))))
|
|
||||||
|
|
||||||
(define* (deduplicate path hash #:key (store %store-directory))
|
(define* (deduplicate path hash #:key (store %store-directory))
|
||||||
"Check if a store item with sha256 hash HASH already exists. If so,
|
"Check if a store item with sha256 hash HASH already exists. If so,
|
||||||
|
|
Reference in New Issue