unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
blob a72a43bf79b116cd9a6ced307bc8ea2d1e704c3e 12153 bytes (raw)
name: guix/store/deduplication.scm 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

;;; This houses stuff we do to files when they arrive at the store - resetting
;;; timestamps, deduplicating, etc.

(define-module (guix store deduplication)
  #:use-module (gcrypt hash)
  #:use-module (guix build utils)
  #:use-module (guix build syscalls)
  #:use-module (guix base32)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (guix serialization)
  #:export (nar-sha256
            deduplicate
            dump-file/deduplicate
            copy-file/deduplicate))

;; XXX: This port is used as a workaround on Guile <= 2.2.4 where
;; 'port-position' throws to 'out-of-range' when the offset is great than or
;; equal to 2^32: <https://bugs.gnu.org/32161>.
(define (counting-wrapper-port output-port)
  "Return two values: an output port that wraps OUTPUT-PORT, and a thunk to
retrieve the number of bytes written to OUTPUT-PORT."
  (let ((byte-count 0))
    (values (make-custom-binary-output-port "counting-wrapper"
                                            (lambda (bytes offset count)
                                              (put-bytevector output-port bytes
                                                              offset count)
                                              (set! byte-count
                                                (+ byte-count count))
                                              count)
                                            (lambda ()
                                              byte-count)
                                            #f
                                            (lambda ()
                                              (close-port output-port)))
            (lambda ()
              byte-count))))

(define (nar-sha256 file)
  "Gives the sha256 hash of a file and the size of the file in nar form."
  (let*-values (((port get-hash) (open-sha256-port))
                ((wrapper get-size) (counting-wrapper-port port)))
    (write-file file wrapper)
    (force-output wrapper)
    (force-output port)
    (let ((hash (get-hash))
          (size (get-size)))
      (close-port wrapper)
      (values hash size))))

(define (tempname-in directory)
  "Gives an unused temporary name under DIRECTORY. Not guaranteed to still be
unused by the time you create anything with that name, but a good shot."
  (let ((const-part (string-append directory "/.tmp-link-"
                                   (number->string (getpid)))))
    (let try ((guess-part
               (number->string (random most-positive-fixnum) 16)))
      (if (file-exists? (string-append const-part "-" guess-part))
          (try (number->string (random most-positive-fixnum) 16))
          (string-append const-part "-" guess-part)))))

(define* (get-temp-link target #:optional (link-prefix (dirname target)))
  "Like mkstemp!, but instead of creating a new file and giving you the name,
it creates a new hardlink to TARGET and gives you the name. Since
cross-file-system hardlinks don't work, the temp link must be created on the
same file system - where in that file system it is can be controlled by
LINK-PREFIX."
  (let try ((tempname (tempname-in link-prefix)))
    (catch 'system-error
      (lambda ()
        (link target tempname)
        tempname)
      (lambda args
        (if (= (system-error-errno args) EEXIST)
            (try (tempname-in link-prefix))
            (apply throw args))))))

(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
          (lambda ()
            (make-file-writable file))
          thunk
          (lambda ()
            (set-file-time file stat)
            (chmod file (stat:mode stat)))))))

(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 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))
                            (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.

Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
  (define temp-link
    (catch 'system-error
      (lambda ()
        (get-temp-link target swap-directory))
      (lambda args
        ;; We get ENOSPC when we can't fit an additional entry in
        ;; SWAP-DIRECTORY.  If it's EMLINK, then TARGET has reached its
        ;; maximum number of links.
        (if (memv (system-error-errno args) `(,ENOSPC ,EMLINK))
            #f
            (apply throw args)))))

  ;; 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) store
      (catch 'system-error
        (lambda ()
          (rename-file temp-link to-replace))
        (lambda args
          (delete-file temp-link)
          (unless (= EMLINK (system-error-errno args))
            (apply throw args)))))))

(define* (deduplicate path hash #:key (store (%store-directory)))
  "Check if a store item with sha256 hash HASH already exists.  If so,
replace PATH with a hardlink to the already-existing one.  If not, register
PATH so that future duplicates can hardlink to it.  PATH is assumed to be
under STORE."
  (define links-directory
    (string-append store "/.links"))

  (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 ENOENT)
                           ;; This most likely means that LINKS-DIRECTORY does
                           ;; not exist.  Attempt to create it and try again.
                           (mkdir-p links-directory)
                           (loop path type hash))
                          ((= 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)))))))))))

(define (tee input len output)
  "Return a port that reads up to LEN bytes from INPUT and writes them to
OUTPUT as it goes."
  (define bytes-read 0)

  (define (fail)
    ;; Reached EOF before we had read LEN bytes from INPUT.
    (raise (condition
            (&nar-error (port input)
                        (file (port-filename output))))))

  (define (read! bv start count)
    ;; Read at most LEN bytes in total.
    (let ((count (min count (- len bytes-read))))
      (let loop ((ret (get-bytevector-n! input bv start count)))
        (cond ((eof-object? ret)
               (if (= bytes-read len)
                   0                              ; EOF
                   (fail)))
              ((and (zero? ret) (> count 0))
               ;; Do not return zero since zero means EOF, so try again.
               (loop (get-bytevector-n! input bv start count)))
              (else
               (put-bytevector output bv start ret)
               (set! bytes-read (+ bytes-read ret))
               ret)))))

  (make-custom-binary-input-port "tee input port" read! #f #f #f))

(define* (dump-file/deduplicate file input size type
                                #:key (store (%store-directory)))
  "Write SIZE bytes read from INPUT to FILE.  TYPE is a symbol, either
'regular or 'executable.

This procedure is suitable as a #:dump-file argument to 'restore-file'.  When
used that way, it deduplicates files on the fly as they are restored, thereby
removing the need to a deduplication pass that would re-read all the files
down the road."
  (define hash
    (call-with-output-file file
      (lambda (output)
        (let-values (((hash-port get-hash)
                      (open-hash-port (hash-algorithm sha256))))
          (write-file-tree file hash-port
                           #:file-type+size (lambda (_) (values type size))
                           #:file-port
                           (const (tee input size output)))
          (close-port hash-port)
          (get-hash)))))

  (deduplicate file hash #:store store))

(define* (copy-file/deduplicate source target
                                #:key (store (%store-directory)))
  "Like 'copy-file', but additionally deduplicate TARGET in STORE."
  (call-with-input-file source
    (lambda (input)
      (let ((stat (stat input)))
        (dump-file/deduplicate target input (stat:size stat)
                               (if (zero? (logand (stat:mode stat)
                                                  #o100))
                                   'regular
                                   'executable)
                               #:store store)))))

debug log:

solving a72a43bf79 ...
found a72a43bf79 in https://git.savannah.gnu.org/cgit/guix.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).