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