You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

153 lines
6.9 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
  3. ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
  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. ;;; This houses stuff we do to files when they arrive at the store - resetting
  20. ;;; timestamps, deduplicating, etc.
  21. (define-module (guix store deduplication)
  22. #:use-module (gcrypt hash)
  23. #:use-module (guix build utils)
  24. #:use-module (guix base16)
  25. #:use-module (srfi srfi-11)
  26. #:use-module (rnrs io ports)
  27. #:use-module (ice-9 ftw)
  28. #:use-module (guix serialization)
  29. #:export (nar-sha256
  30. deduplicate))
  31. ;; XXX: This port is used as a workaround on Guile <= 2.2.4 where
  32. ;; 'port-position' throws to 'out-of-range' when the offset is great than or
  33. ;; equal to 2^32: <https://bugs.gnu.org/32161>.
  34. (define (counting-wrapper-port output-port)
  35. "Return two values: an output port that wraps OUTPUT-PORT, and a thunk to
  36. retrieve the number of bytes written to OUTPUT-PORT."
  37. (let ((byte-count 0))
  38. (values (make-custom-binary-output-port "counting-wrapper"
  39. (lambda (bytes offset count)
  40. (put-bytevector output-port bytes
  41. offset count)
  42. (set! byte-count
  43. (+ byte-count count))
  44. count)
  45. (lambda ()
  46. byte-count)
  47. #f
  48. (lambda ()
  49. (close-port output-port)))
  50. (lambda ()
  51. byte-count))))
  52. (define (nar-sha256 file)
  53. "Gives the sha256 hash of a file and the size of the file in nar form."
  54. (let*-values (((port get-hash) (open-sha256-port))
  55. ((wrapper get-size) (counting-wrapper-port port)))
  56. (write-file file wrapper)
  57. (force-output wrapper)
  58. (force-output port)
  59. (let ((hash (get-hash))
  60. (size (get-size)))
  61. (close-port wrapper)
  62. (values hash size))))
  63. (define (tempname-in directory)
  64. "Gives an unused temporary name under DIRECTORY. Not guaranteed to still be
  65. unused by the time you create anything with that name, but a good shot."
  66. (let ((const-part (string-append directory "/.tmp-link-"
  67. (number->string (getpid)))))
  68. (let try ((guess-part
  69. (number->string (random most-positive-fixnum) 16)))
  70. (if (file-exists? (string-append const-part "-" guess-part))
  71. (try (number->string (random most-positive-fixnum) 16))
  72. (string-append const-part "-" guess-part)))))
  73. (define* (get-temp-link target #:optional (link-prefix (dirname target)))
  74. "Like mkstemp!, but instead of creating a new file and giving you the name,
  75. it creates a new hardlink to TARGET and gives you the name. Since
  76. cross-filesystem hardlinks don't work, the temp link must be created on the
  77. same filesystem - where in that filesystem it is can be controlled by
  78. LINK-PREFIX."
  79. (let try ((tempname (tempname-in link-prefix)))
  80. (catch 'system-error
  81. (lambda ()
  82. (link target tempname)
  83. tempname)
  84. (lambda args
  85. (if (= (system-error-errno args) EEXIST)
  86. (try (tempname-in link-prefix))
  87. (apply throw args))))))
  88. ;; There are 3 main kinds of errors we can get from hardlinking: "Too many
  89. ;; things link to this" (EMLINK), "this link already exists" (EEXIST), and
  90. ;; "can't fit more stuff in this directory" (ENOSPC).
  91. (define* (replace-with-link target to-replace
  92. #:key (swap-directory (dirname target)))
  93. "Atomically replace the file TO-REPLACE with a link to TARGET. Use
  94. SWAP-DIRECTORY as the directory to store temporary hard links.
  95. Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
  96. (let ((temp-link (get-temp-link target swap-directory)))
  97. (make-file-writable (dirname to-replace))
  98. (catch 'system-error
  99. (lambda ()
  100. (rename-file temp-link to-replace))
  101. (lambda args
  102. (delete-file temp-link)
  103. (unless (= EMLINK (system-error-errno args))
  104. (apply throw args))))))
  105. (define* (deduplicate path hash #:key (store %store-directory))
  106. "Check if a store item with sha256 hash HASH already exists. If so,
  107. replace PATH with a hardlink to the already-existing one. If not, register
  108. PATH so that future duplicates can hardlink to it. PATH is assumed to be
  109. under STORE."
  110. (let* ((links-directory (string-append store "/.links"))
  111. (link-file (string-append links-directory "/"
  112. (bytevector->base16-string hash))))
  113. (mkdir-p links-directory)
  114. (if (eq? 'directory (stat:type (lstat path)))
  115. ;; Can't hardlink directories, so hardlink their atoms.
  116. (for-each (lambda (file)
  117. (unless (or (member file '("." ".."))
  118. (and (string=? path store)
  119. (string=? file ".links")))
  120. (let ((file (string-append path "/" file)))
  121. (deduplicate file (nar-sha256 file)
  122. #:store store))))
  123. (scandir path))
  124. (if (file-exists? link-file)
  125. (replace-with-link link-file path
  126. #:swap-directory links-directory)
  127. (catch 'system-error
  128. (lambda ()
  129. (link path link-file))
  130. (lambda args
  131. (let ((errno (system-error-errno args)))
  132. (cond ((= errno EEXIST)
  133. ;; Someone else put an entry for PATH in
  134. ;; LINKS-DIRECTORY before we could. Let's use it.
  135. (replace-with-link path link-file
  136. #:swap-directory links-directory))
  137. ((= errno ENOSPC)
  138. ;; There's not enough room in the directory index for
  139. ;; more entries in .links, but that's fine: we can
  140. ;; just stop.
  141. #f)
  142. (else (apply throw args))))))))))