projects/guix·blob 7866294e · refs

281 lines · 11.7 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017 Caleb Ristvedt <[email protected]>
3;;; Copyright © 2018-2022 Ludovic Courtès <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20;;; This houses stuff we do to files when they arrive at the store - resetting
21;;; timestamps, deduplicating, etc.
22
23(define-module (guix store deduplication)
24 #:use-module (gcrypt hash)
25 #:use-module (guix build utils)
26 #:use-module (guix build syscalls)
27 #:use-module (guix base32)
28 #:use-module (srfi srfi-11)
29 #:use-module (srfi srfi-34)
30 #:use-module (srfi srfi-35)
31 #:use-module (rnrs bytevectors)
32 #:use-module (rnrs io ports)
33 #:use-module (ice-9 ftw)
34 #:use-module (ice-9 match)
35 #:use-module (guix serialization)
36 #:export (nar-sha256
37 deduplicate
38 dump-file/deduplicate
39 copy-file/deduplicate))
40
41(define (nar-sha256 file)
42 "Gives the sha256 hash of a file and the size of the file in nar form."
43 (let-values (((port get-hash) (open-sha256-port)))
44 (write-file file port)
45 (force-output port)
46 (let ((hash (get-hash))
47 (size (port-position port)))
48 (close-port port)
49 (values hash size))))
50
51(define (tempname-in directory)
52 "Gives an unused temporary name under DIRECTORY. Not guaranteed to still be
53unused by the time you create anything with that name, but a good shot."
54 (let ((const-part (string-append directory "/.tmp-link-"
55 (number->string (getpid)))))
56 (let try ((guess-part
57 (number->string (random most-positive-fixnum) 16)))
58 (if (file-exists? (string-append const-part "-" guess-part))
59 (try (number->string (random most-positive-fixnum) 16))
60 (string-append const-part "-" guess-part)))))
61
62(define* (get-temp-link target #:optional (link-prefix (dirname target)))
63 "Like mkstemp!, but instead of creating a new file and giving you the name,
64it creates a new hardlink to TARGET and gives you the name. Since
65cross-file-system hardlinks don't work, the temp link must be created on the
66same file system - where in that file system it is can be controlled by
67LINK-PREFIX."
68 (let try ((tempname (tempname-in link-prefix)))
69 (catch 'system-error
70 (lambda ()
71 (link target tempname)
72 tempname)
73 (lambda args
74 (if (= (system-error-errno args) EEXIST)
75 (try (tempname-in link-prefix))
76 (apply throw args))))))
77
78(define (call-with-writable-file file store thunk)
79 (if (string=? file store)
80 (thunk) ;don't meddle with the store's permissions
81 (let ((stat (lstat file)))
82 (dynamic-wind
83 (lambda ()
84 (make-file-writable file))
85 thunk
86 (lambda ()
87 (set-file-time file stat)
88 (chmod file (stat:mode stat)))))))
89
90(define-syntax-rule (with-writable-file file store exp ...)
91 "Make FILE writable for the dynamic extent of EXP..., except if FILE is the
92store."
93 (call-with-writable-file file store (lambda () exp ...)))
94
95;; There are 3 main kinds of errors we can get from hardlinking: "Too many
96;; things link to this" (EMLINK), "this link already exists" (EEXIST), and
97;; "can't fit more stuff in this directory" (ENOSPC).
98
99(define* (replace-with-link target to-replace
100 #:key (swap-directory (dirname target))
101 (store (%store-directory)))
102 "Atomically replace the file TO-REPLACE with a link to TARGET. Use
103SWAP-DIRECTORY as the directory to store temporary hard links. Upon ENOSPC
104and EMLINK, TO-REPLACE is left unchanged.
105
106Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
107 (define temp-link
108 (catch 'system-error
109 (lambda ()
110 (get-temp-link target swap-directory))
111 (lambda args
112 ;; We get ENOSPC when we can't fit an additional entry in
113 ;; SWAP-DIRECTORY. If it's EMLINK, then TARGET has reached its
114 ;; maximum number of links.
115 (if (memv (system-error-errno args) `(,ENOSPC ,EMLINK))
116 #f
117 (apply throw args)))))
118
119 ;; If we couldn't create TEMP-LINK, that's OK: just don't do the
120 ;; replacement, which means TO-REPLACE won't be deduplicated.
121 (when temp-link
122 (with-writable-file (dirname to-replace) store
123 (catch 'system-error
124 (lambda ()
125 (rename-file temp-link to-replace))
126 (lambda args
127 (delete-file temp-link)
128 (unless (= EMLINK (system-error-errno args))
129 (apply throw args)))))))
130
131(define %deduplication-minimum-size
132 ;; Size below which files are not deduplicated. This avoids adding too many
133 ;; entries to '.links', which would slow down 'removeUnusedLinks' while
134 ;; saving little space. Keep in sync with optimize-store.cc.
135 8192)
136
137(define* (deduplicate path hash #:key (store (%store-directory)))
138 "Check if a store item with sha256 hash HASH already exists. If so,
139replace PATH with a hardlink to the already-existing one. If not, register
140PATH so that future duplicates can hardlink to it. PATH is assumed to be
141under STORE."
142 ;; Lightweight promises.
143 (define-syntax-rule (delay exp)
144 (let ((value #f))
145 (lambda ()
146 (unless value
147 (set! value exp))
148 value)))
149 (define-syntax-rule (force promise)
150 (promise))
151
152 (define links-directory
153 (string-append store "/.links"))
154
155 (let loop ((path path)
156 (type (stat:type (lstat path)))
157 (hash hash))
158 (if (eq? 'directory type)
159 ;; Can't hardlink directories, so hardlink their atoms.
160 (for-each (match-lambda
161 ((file . properties)
162 (unless (member file '("." ".."))
163 (let* ((file (string-append path "/" file))
164 (st (delay (lstat file)))
165 (type (match (assoc-ref properties 'type)
166 ((or 'unknown #f)
167 (stat:type (force st)))
168 (type type))))
169 (when (or (eq? 'directory type)
170 (and (eq? 'regular type)
171 (>= (stat:size (force st))
172 %deduplication-minimum-size)))
173 (loop file type
174 (and (not (eq? 'directory type))
175 (nar-sha256 file))))))))
176 (scandir* path))
177 (let ((link-file (string-append links-directory "/"
178 (bytevector->nix-base32-string hash))))
179 (if (file-exists? link-file)
180 (replace-with-link link-file path
181 #:swap-directory links-directory
182 #:store store)
183 (catch 'system-error
184 (lambda ()
185 (link path link-file))
186 (lambda args
187 (let ((errno (system-error-errno args)))
188 (cond ((= errno EEXIST)
189 ;; Someone else put an entry for PATH in
190 ;; LINKS-DIRECTORY before we could. Let's use it.
191 (replace-with-link path link-file
192 #:swap-directory
193 links-directory
194 #:store store))
195 ((= errno ENOENT)
196 ;; This most likely means that LINKS-DIRECTORY does
197 ;; not exist. Attempt to create it and try again.
198 (mkdir-p links-directory)
199 (loop path type hash))
200 ((= errno ENOSPC)
201 ;; There's not enough room in the directory index for
202 ;; more entries in .links, but that's fine: we can
203 ;; just stop.
204 #f)
205 ((= errno EMLINK)
206 ;; PATH has reached the maximum number of links, but
207 ;; that's OK: we just can't deduplicate it more.
208 #f)
209 (else (apply throw args)))))))))))
210
211(define (tee input len output)
212 "Return a port that reads up to LEN bytes from INPUT and writes them to
213OUTPUT as it goes."
214 (define bytes-read 0)
215
216 (define (fail)
217 ;; Reached EOF before we had read LEN bytes from INPUT.
218 (raise (condition
219 (&nar-error (port input)
220 (file (port-filename output))))))
221
222 (define (read! bv start count)
223 ;; Read at most LEN bytes in total.
224 (let ((count (min count (- len bytes-read))))
225 (let loop ((ret (get-bytevector-n! input bv start count)))
226 (cond ((eof-object? ret)
227 (if (= bytes-read len)
228 0 ; EOF
229 (fail)))
230 ((and (zero? ret) (> count 0))
231 ;; Do not return zero since zero means EOF, so try again.
232 (loop (get-bytevector-n! input bv start count)))
233 (else
234 (put-bytevector output bv start ret)
235 (set! bytes-read (+ bytes-read ret))
236 ret)))))
237
238 (make-custom-binary-input-port "tee input port" read! #f #f #f))
239
240(define* (dump-file/deduplicate file input size type
241 #:key (store (%store-directory)))
242 "Write SIZE bytes read from INPUT to FILE. TYPE is a symbol, either
243'regular or 'executable.
244
245This procedure is suitable as a #:dump-file argument to 'restore-file'. When
246used that way, it deduplicates files on the fly as they are restored, thereby
247removing the need for a deduplication pass that would re-read all the files
248down the road."
249 (define (dump-and-compute-hash)
250 (call-with-output-file file
251 (lambda (output)
252 (let-values (((hash-port get-hash)
253 (open-hash-port (hash-algorithm sha256))))
254 (write-file-tree file hash-port
255 #:file-type+size (lambda (_) (values type size))
256 #:file-port
257 (const (tee input size output)))
258 (close-port hash-port)
259 (get-hash)))))
260
261 (if (>= size %deduplication-minimum-size)
262 (deduplicate file (dump-and-compute-hash) #:store store)
263 (call-with-output-file file
264 (lambda (output)
265 (if (file-port? input)
266 (sendfile output input size 0)
267 (dump-port input output size
268 #:buffer-size %deduplication-minimum-size))))))
269
270(define* (copy-file/deduplicate source target
271 #:key (store (%store-directory)))
272 "Like 'copy-file', but additionally deduplicate TARGET in STORE."
273 (call-with-input-file source
274 (lambda (input)
275 (let ((stat (stat input)))
276 (dump-file/deduplicate target input (stat:size stat)
277 (if (zero? (logand (stat:mode stat)
278 #o100))
279 'regular
280 'executable)
281 #:store store)))))