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: pass store directory to replace-with-link.

Browse source 
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>
This commit is contained in:
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/no-wait '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/inherit 'scheme-indent-function 1))

102
guix/store/deduplication.scm
View file

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