gnu: r-qtl2: Move to (gnu packages cran).
[jackhill/guix/guix.git] / guix / nar.scm
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2014 Mark H Weaver <mhw@netris.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
20 (define-module (guix nar)
21 #:use-module (guix serialization)
22 #:use-module (guix build syscalls)
23 #:use-module ((guix build utils)
24 #:select (delete-file-recursively with-directory-excursion))
25
26 ;; XXX: Eventually we should use (guix store database) exclusively, and not
27 ;; (guix store) since this is "daemon-side" code.
28 #:use-module (guix store)
29 #:use-module (guix store database)
30 #:use-module ((guix build store-copy) #:select (store-info))
31
32 #:use-module (guix i18n)
33 #:use-module (gcrypt hash)
34 #:use-module (guix pki)
35 #:use-module (gcrypt pk-crypto)
36 #:use-module (srfi srfi-1)
37 #:use-module (srfi srfi-11)
38 #:use-module (srfi srfi-26)
39 #:use-module (srfi srfi-34)
40 #:use-module (srfi srfi-35)
41 #:export (nar-invalid-hash-error?
42 nar-invalid-hash-error-expected
43 nar-invalid-hash-error-actual
44
45 nar-signature-error?
46 nar-signature-error-signature
47
48 restore-file-set))
49
50 ;;; Comment:
51 ;;;
52 ;;; Read and write Nix archives, aka. ‘nar’.
53 ;;;
54 ;;; Code:
55
56 (define-condition-type &nar-signature-error &nar-error
57 nar-signature-error?
58 (signature nar-signature-error-signature)) ; faulty signature or #f
59
60 (define-condition-type &nar-invalid-hash-error &nar-signature-error
61 nar-invalid-hash-error?
62 (expected nar-invalid-hash-error-expected) ; expected hash (a bytevector)
63 (actual nar-invalid-hash-error-actual)) ; actual hash
64
65
66 \f
67 ;;;
68 ;;; Restoring a file set into the store.
69 ;;;
70
71 ;; The code below accesses the store directly and is meant to be run from
72 ;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since
73 ;; (1) the locks on the files to be restored as already held, and (2) the
74 ;; $NIX_HELD_LOCKS hackish environment variable cannot be set.
75 ;;
76 ;; So we're really duplicating that functionality of the daemon (well, until
77 ;; most of the daemon is in Scheme :-)). But note that we do use a couple of
78 ;; RPCs for functionality not available otherwise, like 'valid-path?'.
79
80 (define* (finalize-store-file source target
81 #:key (references '()) deriver (lock? #t))
82 "Rename SOURCE to TARGET and register TARGET as a valid store item, with
83 REFERENCES and DERIVER. When LOCK? is true, acquire exclusive locks on TARGET
84 before attempting to register it; otherwise, assume TARGET's locks are already
85 held."
86 ;; TODO: make this reusable
87 (define (acquire-lock file)
88 (let ((port (lock-file file)))
89 ;; There is an inherent race condition between opening the lock file and
90 ;; attempting to acquire the lock on it, and because we like deleting
91 ;; these lock files when we release them, only the first successful
92 ;; acquisition on a given lock file matters. To make it easier to tell
93 ;; when an acquisition is and isn't the first, the first to acquire it
94 ;; writes a deletion token (arbitrary character) prior to releasing the
95 ;; lock.
96 (if (zero? (stat:size (stat port)))
97 port
98 ;; if FILE is non-empty, that's because it contains the deletion
99 ;; token, so we aren't the first to acquire it. So try again!
100 (begin
101 (close port)
102 (acquire-lock file)))))
103
104 (with-database %default-database-file db
105 (unless (path-id db target)
106 (let ((lock (and lock?
107 (acquire-lock (string-append target ".lock")))))
108
109 (unless (path-id db target)
110 ;; If FILE already exists, delete it (it's invalid anyway.)
111 (when (file-exists? target)
112 (delete-file-recursively target))
113
114 ;; Install the new TARGET.
115 (rename-file source target)
116
117 ;; Register TARGET. As a side effect, it resets the timestamps of all
118 ;; its files, recursively, and runs a deduplication pass.
119 (register-items db
120 (list (store-info target deriver references))))
121
122 (when lock?
123 (delete-file (string-append target ".lock"))
124 ;; Write the deletion token to inform anyone who acquires the lock
125 ;; on this particular file next that they aren't the first to
126 ;; acquire it, so they should retry.
127 (display "d" lock)
128 (force-output lock)
129 (unlock-file lock))))))
130
131 (define (temporary-store-file)
132 "Return the file name of a temporary file created in the store."
133 (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
134 (port (mkstemp! template)))
135 (close-port port)
136 template))
137
138 (define-syntax-rule (with-temporary-store-file name body ...)
139 "Evaluate BODY with NAME bound to the file name of a temporary store item
140 protected from GC."
141 (with-store store
142 (let loop ((name (temporary-store-file)))
143 ;; Add NAME to the current process' roots. (Opening this connection to
144 ;; the daemon allows us to reuse its code that deals with the
145 ;; per-process roots file.)
146 (add-temp-root store name)
147
148 ;; There's a window during which GC could delete NAME. Try again when
149 ;; that happens.
150 (if (file-exists? name)
151 (begin
152 (delete-file name)
153 body ...)
154 (loop (temporary-store-file))))))
155
156 (define* (restore-one-item port
157 #:key acl (verify-signature? #t) (lock? #t)
158 (log-port (current-error-port)))
159 "Restore one store item of a nar bundle read from PORT; return its file name
160 on success."
161
162 (define (assert-valid-signature signature hash file)
163 ;; Bail out if SIGNATURE, which must be a string as produced by
164 ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
165 ;; the expected hash for FILE.
166 (let ((signature (catch 'gcry-error
167 (lambda ()
168 (string->canonical-sexp signature))
169 (lambda (key proc err)
170 (raise (condition
171 (&message
172 (message "signature is not a valid \
173 s-expression"))
174 (&nar-signature-error
175 (file file)
176 (signature signature) (port port))))))))
177 (signature-case (signature hash (current-acl))
178 (valid-signature #t)
179 (invalid-signature
180 (raise (condition
181 (&message (message "invalid signature"))
182 (&nar-signature-error
183 (file file) (signature signature) (port port)))))
184 (hash-mismatch
185 (raise (condition (&message (message "invalid hash"))
186 (&nar-invalid-hash-error
187 (port port) (file file)
188 (signature signature)
189 (expected (hash-data->bytevector
190 (signature-signed-data signature)))
191 (actual hash)))))
192 (unauthorized-key
193 (raise (condition (&message (message "unauthorized public key"))
194 (&nar-signature-error
195 (signature signature) (file file) (port port)))))
196 (corrupt-signature
197 (raise (condition
198 (&message (message "corrupt signature data"))
199 (&nar-signature-error
200 (signature signature) (file file) (port port))))))))
201
202 (define %export-magic
203 ;; Number used to identify genuine file set archives.
204 #x4558494e)
205
206 (define port*
207 ;; Keep that one around, for error conditions.
208 port)
209
210 (let-values (((port get-hash)
211 (open-sha256-input-port port)))
212 (with-temporary-store-file temp
213 (restore-file port temp)
214
215 (let ((magic (read-int port)))
216 (unless (= magic %export-magic)
217 (raise (condition
218 (&message (message "corrupt file set archive"))
219 (&nar-read-error
220 (port port*) (file #f) (token #f))))))
221
222 (let ((file (read-store-path port))
223 (refs (read-store-path-list port))
224 (deriver (read-string port))
225 (hash (get-hash))
226 (has-sig? (= 1 (read-int port))))
227 (format log-port
228 (G_ "importing file or directory '~a'...~%")
229 file)
230
231 ;; The signature may contain characters that are meant to be
232 ;; interpreted as bytes in a 'char *', so read them as a ISO-8859-1.
233 (let ((sig (and has-sig? (read-latin1-string port))))
234 (when verify-signature?
235 (if sig
236 (begin
237 (assert-valid-signature sig hash file)
238 (format log-port
239 (G_ "found valid signature for '~a'~%")
240 file)
241 (finalize-store-file temp file
242 #:references refs
243 #:deriver deriver
244 #:lock? lock?))
245 (raise (condition
246 (&message (message "imported file lacks \
247 a signature"))
248 (&nar-signature-error
249 (port port*) (file file) (signature #f))))))
250 file)))))
251
252 (define* (restore-file-set port
253 #:key (verify-signature? #t) (lock? #t)
254 (log-port (current-error-port)))
255 "Restore the file set (\"nar bundle\") read from PORT to the store. The
256 format of the data on PORT must be as created by 'export-paths'---i.e., a
257 series of Nar-formatted archives with interspersed meta-data joining them
258 together, possibly with a digital signature at the end. Log progress to
259 LOG-PORT. Return the list of files restored.
260
261 When LOCK? is #f, assume locks for the files to be restored are already held.
262 This is the case when the daemon calls a build hook.
263
264 Note that this procedure accesses the store directly, so it's only meant to be
265 used by the daemon's build hooks since they cannot call back to the daemon
266 while the locks are held."
267 (define acl
268 (current-acl))
269
270 (let loop ((n (read-long-long port))
271 (files '()))
272 (case n
273 ((0)
274 (reverse files))
275 ((1)
276 (let ((file
277 (restore-one-item port
278 #:acl acl #:verify-signature? verify-signature?
279 #:lock? lock? #:log-port log-port)))
280 (loop (read-long-long port)
281 (cons file files))))
282 (else
283 ;; Neither 0 nor 1.
284 (raise (condition
285 (&message (message "invalid inter-file archive mark"))
286 (&nar-read-error
287 (port port) (file #f) (token #f))))))))
288
289 ;;; Local Variables:
290 ;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1)
291 ;;; End:
292
293 ;;; nar.scm ends here