ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

deduplication: Use 'dynamic-wind' when changing permissions of the parent.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2020-06-25 10:10:09 +02:00
parent b930f0ba21
commit d52e16d3b6
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 17 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -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))

24
guix/store/deduplication.scm
View file

@ -94,6 +94,20 @@ (define* (get-temp-link target #:optional (link-prefix (dirname target)))
(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 @@ (define temp-link
;; 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,