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