me
/
guix
Archived
1
0
Fork 0
Code

deduplication: pass store directory to replace-with-link. 

This causes with-writable-file to take into consideration the actual store
being used, as passed to 'deduplicate', rather than
whatever (%store-directory) may return.

* guix/store/deduplication.scm (replace-with-link): new keyword argument
  'store'.  Pass to with-writable-file.
  (with-writable-file, call-with-writable-file): new store argument.
  (deduplicate): pass store to replace-with-link.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
master
Caleb Ristvedt 2020-08-08 10:05:22 -05:00 committed by Ludovic Courtès
parent 1d40e6fdd1
commit 14c422c12c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 54 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.dir-locals.el
View File

@ -37,7 +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 'with-writable-file 'scheme-indent-function 2))
(eval . (put 'package 'scheme-indent-function 0)) (eval . (put 'package 'scheme-indent-function 0))
(eval . (put 'package/inherit 'scheme-indent-function 1)) (eval . (put 'package/inherit 'scheme-indent-function 1))

102
guix/store/deduplication.scm
View File

@ -94,8 +94,8 @@ 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) (define (call-with-writable-file file store thunk)
(if (string=? file (%store-directory)) (if (string=? file store)
(thunk) ;don't meddle with the store's permissions (thunk) ;don't meddle with the store's permissions
(let ((stat (lstat file))) (let ((stat (lstat file)))
(dynamic-wind (dynamic-wind
@ -106,17 +106,18 @@ LINK-PREFIX."
(set-file-time file stat) (set-file-time file stat)
(chmod file (stat:mode stat))))))) (chmod file (stat:mode stat)))))))
(define-syntax-rule (with-writable-file file exp ...) (define-syntax-rule (with-writable-file file store exp ...)
"Make FILE writable for the dynamic extent of EXP..., except if FILE is the "Make FILE writable for the dynamic extent of EXP..., except if FILE is the
store." store."
(call-with-writable-file file (lambda () exp ...))) (call-with-writable-file file store (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).
(define* (replace-with-link target to-replace (define* (replace-with-link target to-replace
#:key (swap-directory (dirname target))) #:key (swap-directory (dirname target))
(store (%store-directory)))
"Atomically replace the file TO-REPLACE with a link to TARGET. Use "Atomically replace the file TO-REPLACE with a link to TARGET. Use
SWAP-DIRECTORY as the directory to store temporary hard links. Upon ENOSPC SWAP-DIRECTORY as the directory to store temporary hard links. Upon ENOSPC
and EMLINK, TO-REPLACE is left unchanged. and EMLINK, TO-REPLACE is left unchanged.
@ -137,7 +138,7 @@ 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
(with-writable-file (dirname to-replace) (with-writable-file (dirname to-replace) store
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
(rename-file temp-link to-replace)) (rename-file temp-link to-replace))
@ -154,46 +155,49 @@ under STORE."
(define links-directory (define links-directory
(string-append store "/.links")) (string-append store "/.links"))
(mkdir-p links-directory) (mkdir-p links-directory)
(let loop ((path path) (let loop ((path path)
(type (stat:type (lstat path))) (type (stat:type (lstat path)))
(hash hash)) (hash hash))
(if (eq? 'directory type) (if (eq? 'directory type)
;; Can't hardlink directories, so hardlink their atoms. ;; Can't hardlink directories, so hardlink their atoms.
(for-each (match-lambda (for-each (match-lambda
((file . properties) ((file . properties)
(unless (member file '("." "..")) (unless (member file '("." ".."))
(let* ((file (string-append path "/" file)) (let* ((file (string-append path "/" file))
(type (match (assoc-ref properties 'type) (type (match (assoc-ref properties 'type)
((or 'unknown #f) ((or 'unknown #f)
(stat:type (lstat file))) (stat:type (lstat file)))
(type type)))) (type type))))
(loop file type (loop file type
(and (not (eq? 'directory type)) (and (not (eq? 'directory type))
(nar-sha256 file))))))) (nar-sha256 file)))))))
(scandir* path)) (scandir* path))
(let ((link-file (string-append links-directory "/" (let ((link-file (string-append links-directory "/"
(bytevector->nix-base32-string hash)))) (bytevector->nix-base32-string hash))))
(if (file-exists? link-file) (if (file-exists? link-file)
(replace-with-link link-file path (replace-with-link link-file path
#:swap-directory links-directory) #:swap-directory links-directory
(catch 'system-error #:store store)
(lambda () (catch 'system-error
(link path link-file)) (lambda ()
(lambda args (link path link-file))
(let ((errno (system-error-errno args))) (lambda args
(cond ((= errno EEXIST) (let ((errno (system-error-errno args)))
;; Someone else put an entry for PATH in (cond ((= errno EEXIST)
;; LINKS-DIRECTORY before we could. Let's use it. ;; Someone else put an entry for PATH in
(replace-with-link path link-file ;; LINKS-DIRECTORY before we could. Let's use it.
#:swap-directory links-directory)) (replace-with-link path link-file
((= errno ENOSPC) #:swap-directory
;; There's not enough room in the directory index for links-directory
;; more entries in .links, but that's fine: we can #:store store))
;; just stop. ((= errno ENOSPC)
#f) ;; There's not enough room in the directory index for
((= errno EMLINK) ;; more entries in .links, but that's fine: we can
;; PATH has reached the maximum number of links, but ;; just stop.
;; that's OK: we just can't deduplicate it more. #f)
#f) ((= errno EMLINK)
(else (apply throw args))))))))))) ;; PATH has reached the maximum number of links, but
;; that's OK: we just can't deduplicate it more.
#f)
(else (apply throw args)))))))))))