Commit | Line | Data |
---|---|---|
0f41c26f | 1 | ;;; GNU Guix --- Functional package management for GNU |
7a68d3cc | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
d2d8779b | 3 | ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> |
0f41c26f LC |
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) | |
0f41c26f | 21 | #:use-module (guix serialization) |
4e0ea3eb | 22 | #:use-module (guix build syscalls) |
cd4027fa LC |
23 | #:use-module ((guix build utils) |
24 | #:select (delete-file-recursively with-directory-excursion)) | |
1afe1985 LC |
25 | |
26 | ;; XXX: Eventually we should use (guix store database) exclusively, and not | |
27 | ;; (guix store) since this is "daemon-side" code. | |
cd4027fa | 28 | #:use-module (guix store) |
df2f6400 | 29 | #:use-module (guix store database) |
d7fb5538 | 30 | #:use-module ((guix build store-copy) #:select (store-info)) |
1afe1985 | 31 | |
3b72618f | 32 | #:use-module (guix i18n) |
ca719424 | 33 | #:use-module (gcrypt hash) |
cd4027fa | 34 | #:use-module (guix pki) |
ca719424 | 35 | #:use-module (gcrypt pk-crypto) |
0f41c26f | 36 | #:use-module (srfi srfi-1) |
cd4027fa | 37 | #:use-module (srfi srfi-11) |
0f41c26f | 38 | #:use-module (srfi srfi-26) |
53c63ee9 LC |
39 | #:use-module (srfi srfi-34) |
40 | #:use-module (srfi srfi-35) | |
0363991a | 41 | #:export (nar-invalid-hash-error? |
cd4027fa LC |
42 | nar-invalid-hash-error-expected |
43 | nar-invalid-hash-error-actual | |
44 | ||
45 | nar-signature-error? | |
46 | nar-signature-error-signature | |
47 | ||
cd4027fa | 48 | restore-file-set)) |
0f41c26f LC |
49 | |
50 | ;;; Comment: | |
51 | ;;; | |
52 | ;;; Read and write Nix archives, aka. ‘nar’. | |
53 | ;;; | |
54 | ;;; Code: | |
55 | ||
cd4027fa LC |
56 | (define-condition-type &nar-signature-error &nar-error |
57 | nar-signature-error? | |
58 | (signature nar-signature-error-signature)) ; faulty signature or #f | |
53c63ee9 | 59 | |
cd4027fa LC |
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 | ||
53c63ee9 | 65 | |
cd4027fa LC |
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 | ||
cd4027fa LC |
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." | |
37edbc91 CR |
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 | ||
1afe1985 LC |
104 | (with-database %default-database-file db |
105 | (unless (path-id db target) | |
70a7a1b5 | 106 | (let ((lock (and lock? |
37edbc91 | 107 | (acquire-lock (string-append target ".lock"))))) |
cd4027fa | 108 | |
70a7a1b5 LC |
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)) | |
cd4027fa | 113 | |
70a7a1b5 LC |
114 | ;; Install the new TARGET. |
115 | (rename-file source target) | |
cd4027fa | 116 | |
70a7a1b5 LC |
117 | ;; Register TARGET. As a side effect, it resets the timestamps of all |
118 | ;; its files, recursively, and runs a deduplication pass. | |
d7fb5538 LC |
119 | (register-items db |
120 | (list (store-info target deriver references)))) | |
cd4027fa | 121 | |
70a7a1b5 | 122 | (when lock? |
37edbc91 CR |
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) | |
70a7a1b5 | 129 | (unlock-file lock)))))) |
cd4027fa | 130 | |
6071b55e | 131 | (define (temporary-store-file) |
50db7d82 | 132 | "Return the file name of a temporary file created in the store." |
cd4027fa LC |
133 | (let* ((template (string-append (%store-prefix) "/guix-XXXXXX")) |
134 | (port (mkstemp! template))) | |
135 | (close-port port) | |
50db7d82 | 136 | template)) |
6071b55e LC |
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." | |
b338c41c CR |
141 | (with-store store |
142 | (let loop ((name (temporary-store-file))) | |
50db7d82 LC |
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)))))) | |
6071b55e LC |
155 | |
156 | (define* (restore-one-item port | |
157 | #:key acl (verify-signature? #t) (lock? #t) | |
cd4027fa | 158 | (log-port (current-error-port))) |
7a68d3cc LC |
159 | "Restore one store item of a nar bundle read from PORT; return its file name |
160 | on success." | |
cd4027fa LC |
161 | |
162 | (define (assert-valid-signature signature hash file) | |
24194b6b NK |
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. | |
e4687a5e LC |
166 | (let ((signature (catch 'gcry-error |
167 | (lambda () | |
168 | (string->canonical-sexp signature)) | |
6ef3644e | 169 | (lambda (key proc err) |
e4687a5e LC |
170 | (raise (condition |
171 | (&message | |
172 | (message "signature is not a valid \ | |
cd4027fa | 173 | s-expression")) |
e4687a5e LC |
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)))))))) | |
cd4027fa | 201 | |
6071b55e LC |
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 | |
69daee23 | 228 | (G_ "importing file or directory '~a'...~%") |
6071b55e LC |
229 | file) |
230 | ||
71c1d528 LC |
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)))) | |
6071b55e LC |
234 | (when verify-signature? |
235 | (if sig | |
236 | (begin | |
237 | (assert-valid-signature sig hash file) | |
238 | (format log-port | |
69daee23 | 239 | (G_ "found valid signature for '~a'~%") |
6071b55e LC |
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))) | |
7a68d3cc LC |
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. | |
6071b55e LC |
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 | ||
cd4027fa LC |
270 | (let loop ((n (read-long-long port)) |
271 | (files '())) | |
272 | (case n | |
273 | ((0) | |
274 | (reverse files)) | |
275 | ((1) | |
6071b55e LC |
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)))) | |
cd4027fa LC |
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 | ||
6071b55e LC |
289 | ;;; Local Variables: |
290 | ;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1) | |
291 | ;;; End: | |
292 | ||
0f41c26f | 293 | ;;; nar.scm ends here |