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