Commit | Line | Data |
---|---|---|
760c60d6 | 1 | ;;; GNU Guix --- Functional package management for GNU |
09238d61 | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
760c60d6 LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix scripts archive) | |
20 | #:use-module (guix config) | |
21 | #:use-module (guix utils) | |
958dd3ce | 22 | #:use-module (guix combinators) |
590e4154 | 23 | #:use-module ((guix build utils) #:select (mkdir-p)) |
044277f6 LC |
24 | #:use-module ((guix serialization) |
25 | #:select (fold-archive restore-file)) | |
760c60d6 | 26 | #:use-module (guix store) |
2637cfd7 | 27 | #:use-module ((guix status) #:select (with-status-verbosity)) |
7573d30f | 28 | #:use-module (guix grafts) |
760c60d6 LC |
29 | #:use-module (guix packages) |
30 | #:use-module (guix derivations) | |
257b9341 | 31 | #:use-module (guix monads) |
760c60d6 | 32 | #:use-module (guix ui) |
554f26ec | 33 | #:use-module (guix pki) |
92ca25a3 | 34 | #:use-module (gcrypt common) |
ca719424 | 35 | #:use-module (gcrypt pk-crypto) |
88981dd3 | 36 | #:use-module (guix scripts) |
84189ebc LC |
37 | #:use-module (guix scripts build) |
38 | #:use-module (gnu packages) | |
760c60d6 | 39 | #:use-module (ice-9 match) |
87236aed LC |
40 | #:use-module (ice-9 format) |
41 | #:use-module (ice-9 rdelim) | |
760c60d6 LC |
42 | #:use-module (srfi srfi-1) |
43 | #:use-module (srfi srfi-11) | |
44 | #:use-module (srfi srfi-26) | |
45 | #:use-module (srfi srfi-37) | |
2535635f | 46 | #:use-module (ice-9 binary-ports) |
044277f6 | 47 | #:use-module (rnrs bytevectors) |
f11c444d LC |
48 | #:export (guix-archive |
49 | options->derivations+files)) | |
760c60d6 LC |
50 | |
51 | \f | |
52 | ;;; | |
53 | ;;; Command-line options. | |
54 | ;;; | |
55 | ||
56 | (define %default-options | |
57 | ;; Alist of default option values. | |
b1edfbc3 | 58 | `((system . ,(%current-system)) |
760c60d6 | 59 | (substitutes? . #t) |
7f44ab48 | 60 | (offload? . #t) |
7573d30f | 61 | (graft? . #t) |
f1de676e LC |
62 | (print-build-trace? . #t) |
63 | (print-extended-build-trace? . #t) | |
64 | (multiplexed-build-output? . #t) | |
65 | (verbosity . 2) | |
66 | (debug . 0))) | |
760c60d6 LC |
67 | |
68 | (define (show-help) | |
69daee23 | 69 | (display (G_ "Usage: guix archive [OPTION]... PACKAGE... |
760c60d6 | 70 | Export/import one or more packages from/to the store.\n")) |
69daee23 | 71 | (display (G_ " |
760c60d6 | 72 | --export export the specified files/packages to stdout")) |
69daee23 | 73 | (display (G_ " |
56607088 | 74 | -r, --recursive combined with '--export', include dependencies")) |
69daee23 | 75 | (display (G_ " |
760c60d6 | 76 | --import import from the archive passed on stdin")) |
69daee23 | 77 | (display (G_ " |
87236aed | 78 | --missing print the files from stdin that are missing")) |
69daee23 | 79 | (display (G_ " |
c6f8e9dd | 80 | -x, --extract=DIR extract the archive on stdin to DIR")) |
044277f6 LC |
81 | (display (G_ " |
82 | -t, --list list the files in the archive on stdin")) | |
760c60d6 | 83 | (newline) |
69daee23 | 84 | (display (G_ " |
554f26ec LC |
85 | --generate-key[=PARAMETERS] |
86 | generate a key pair with the given parameters")) | |
69daee23 | 87 | (display (G_ " |
36b56f08 LC |
88 | --authorize authorize imports signed by the public key on stdin")) |
89 | (newline) | |
69daee23 | 90 | (display (G_ " |
760c60d6 | 91 | -e, --expression=EXPR build the package or derivation EXPR evaluates to")) |
69daee23 | 92 | (display (G_ " |
760c60d6 | 93 | -S, --source build the packages' source derivations")) |
69daee23 | 94 | (display (G_ " |
760c60d6 | 95 | -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) |
69daee23 | 96 | (display (G_ " |
760c60d6 | 97 | --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) |
f1de676e LC |
98 | (display (G_ " |
99 | -v, --verbosity=LEVEL use the given verbosity LEVEL")) | |
e7fc17b5 LC |
100 | |
101 | (newline) | |
102 | (show-build-options-help) | |
103 | ||
760c60d6 | 104 | (newline) |
69daee23 | 105 | (display (G_ " |
760c60d6 | 106 | -h, --help display this help and exit")) |
69daee23 | 107 | (display (G_ " |
760c60d6 LC |
108 | -V, --version display version information and exit")) |
109 | (newline) | |
110 | (show-bug-report-information)) | |
111 | ||
1fda6840 LC |
112 | (define %key-generation-parameters |
113 | ;; Default key generation parameters. We prefer Ed25519, but it was | |
114 | ;; introduced in libgcrypt 1.6.0. | |
115 | (if (version>? (gcrypt-version) "1.6.0") | |
116 | "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))" | |
117 | "(genkey (rsa (nbits 4:4096)))")) | |
118 | ||
760c60d6 LC |
119 | (define %options |
120 | ;; Specifications of the command-line options. | |
e7fc17b5 LC |
121 | (cons* (option '(#\h "help") #f #f |
122 | (lambda args | |
123 | (show-help) | |
124 | (exit 0))) | |
125 | (option '(#\V "version") #f #f | |
126 | (lambda args | |
127 | (show-version-and-exit "guix build"))) | |
128 | ||
129 | (option '("export") #f #f | |
130 | (lambda (opt name arg result) | |
131 | (alist-cons 'export #t result))) | |
56607088 LC |
132 | (option '(#\r "recursive") #f #f |
133 | (lambda (opt name arg result) | |
134 | (alist-cons 'export-recursive? #t result))) | |
e7fc17b5 LC |
135 | (option '("import") #f #f |
136 | (lambda (opt name arg result) | |
137 | (alist-cons 'import #t result))) | |
138 | (option '("missing") #f #f | |
139 | (lambda (opt name arg result) | |
140 | (alist-cons 'missing #t result))) | |
c6f8e9dd LC |
141 | (option '("extract" #\x) #t #f |
142 | (lambda (opt name arg result) | |
143 | (alist-cons 'extract arg result))) | |
044277f6 LC |
144 | (option '("list" #\t) #f #f |
145 | (lambda (opt name arg result) | |
146 | (alist-cons 'list #t result))) | |
e7fc17b5 LC |
147 | (option '("generate-key") #f #t |
148 | (lambda (opt name arg result) | |
149 | (catch 'gcry-error | |
150 | (lambda () | |
1cbfce16 LC |
151 | ;; XXX: Curve25519 was actually introduced in |
152 | ;; libgcrypt 1.6.0. | |
e7fc17b5 LC |
153 | (let ((params |
154 | (string->canonical-sexp | |
1fda6840 | 155 | (or arg %key-generation-parameters)))) |
e7fc17b5 | 156 | (alist-cons 'generate-key params result))) |
6ef3644e | 157 | (lambda (key proc err) |
69daee23 | 158 | (leave (G_ "invalid key generation parameters: ~a: ~a~%") |
d0a85069 LC |
159 | (error-source err) |
160 | (error-string err)))))) | |
e7fc17b5 LC |
161 | (option '("authorize") #f #f |
162 | (lambda (opt name arg result) | |
163 | (alist-cons 'authorize #t result))) | |
164 | ||
165 | (option '(#\S "source") #f #f | |
166 | (lambda (opt name arg result) | |
167 | (alist-cons 'source? #t result))) | |
168 | (option '(#\s "system") #t #f | |
169 | (lambda (opt name arg result) | |
170 | (alist-cons 'system arg | |
171 | (alist-delete 'system result eq?)))) | |
172 | (option '("target") #t #f | |
173 | (lambda (opt name arg result) | |
174 | (alist-cons 'target arg | |
175 | (alist-delete 'target result eq?)))) | |
176 | (option '(#\e "expression") #t #f | |
177 | (lambda (opt name arg result) | |
178 | (alist-cons 'expression arg result))) | |
f1de676e LC |
179 | (option '(#\v "verbosity") #t #f |
180 | (lambda (opt name arg result) | |
181 | (let ((level (string->number* arg))) | |
182 | (alist-cons 'verbosity level | |
183 | (alist-delete 'verbosity result))))) | |
e7fc17b5 LC |
184 | (option '(#\n "dry-run") #f #f |
185 | (lambda (opt name arg result) | |
131f50cd | 186 | (alist-cons 'dry-run? #t result))) |
e7fc17b5 LC |
187 | |
188 | %standard-build-options)) | |
760c60d6 | 189 | |
257b9341 LC |
190 | (define (derivation-from-expression store str package-derivation |
191 | system source?) | |
192 | "Read/eval STR and return the corresponding derivation path for SYSTEM. | |
193 | When SOURCE? is true and STR evaluates to a package, return the derivation of | |
194 | the package source; otherwise, use PACKAGE-DERIVATION to compute the | |
195 | derivation of a package." | |
196 | (match (read/eval str) | |
197 | ((? package? p) | |
198 | (if source? | |
199 | (let ((source (package-source p))) | |
200 | (if source | |
201 | (package-source-derivation store source) | |
69daee23 | 202 | (leave (G_ "package `~a' has no source~%") |
257b9341 LC |
203 | (package-name p)))) |
204 | (package-derivation store p system))) | |
205 | ((? procedure? proc) | |
e87f0591 LC |
206 | (run-with-store store |
207 | (mbegin %store-monad | |
208 | (set-guile-for-build (default-guile)) | |
209 | (proc)) #:system system)))) | |
257b9341 | 210 | |
760c60d6 LC |
211 | (define (options->derivations+files store opts) |
212 | "Given OPTS, the result of 'args-fold', return a list of derivations to | |
213 | build and a list of store files to transfer." | |
214 | (define package->derivation | |
215 | (match (assoc-ref opts 'target) | |
216 | (#f package-derivation) | |
217 | (triplet | |
218 | (cut package-cross-derivation <> <> triplet <>)))) | |
219 | ||
220 | (define src? (assoc-ref opts 'source?)) | |
221 | (define sys (assoc-ref opts 'system)) | |
222 | ||
223 | (fold2 (lambda (arg derivations files) | |
224 | (match arg | |
225 | (('expression . str) | |
226 | (let ((drv (derivation-from-expression store str | |
227 | package->derivation | |
228 | sys src?))) | |
229 | (values (cons drv derivations) | |
230 | (cons (derivation->output-path drv) files)))) | |
231 | (('argument . (? store-path? file)) | |
232 | (values derivations (cons file files))) | |
233 | (('argument . (? string? spec)) | |
234 | (let-values (((p output) | |
235 | (specification->package+output spec))) | |
236 | (if src? | |
237 | (let* ((s (package-source p)) | |
238 | (drv (package-source-derivation store s))) | |
239 | (values (cons drv derivations) | |
240 | (cons (derivation->output-path drv) | |
241 | files))) | |
242 | (let ((drv (package->derivation store p sys))) | |
243 | (values (cons drv derivations) | |
244 | (cons (derivation->output-path drv output) | |
245 | files)))))) | |
246 | (_ | |
247 | (values derivations files)))) | |
248 | '() | |
249 | '() | |
250 | opts)) | |
251 | ||
252 | \f | |
253 | ;;; | |
254 | ;;; Entry point. | |
255 | ;;; | |
256 | ||
257 | (define (export-from-store store opts) | |
258 | "Export the packages or derivations specified in OPTS from STORE. Write the | |
259 | resulting archive to the standard output port." | |
260 | (let-values (((drv files) | |
261 | (options->derivations+files store opts))) | |
2d5ee2c6 | 262 | (if (build-derivations store drv) |
b1edfbc3 LC |
263 | (export-paths store files (current-output-port) |
264 | #:recursive? (assoc-ref opts 'export-recursive?)) | |
69daee23 | 265 | (leave (G_ "unable to export the given packages~%"))))) |
554f26ec LC |
266 | |
267 | (define (generate-key-pair parameters) | |
268 | "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the | |
269 | right place." | |
270 | (when (or (file-exists? %public-key-file) | |
271 | (file-exists? %private-key-file)) | |
69daee23 | 272 | (leave (G_ "key pair exists under '~a'; remove it first~%") |
554f26ec LC |
273 | (dirname %public-key-file))) |
274 | ||
275 | (format (current-error-port) | |
69daee23 | 276 | (G_ "Please wait while gathering entropy to generate the key pair; |
554f26ec LC |
277 | this may take time...~%")) |
278 | ||
279 | (let* ((pair (catch 'gcry-error | |
280 | (lambda () | |
281 | (generate-key parameters)) | |
6ef3644e | 282 | (lambda (key proc err) |
69daee23 | 283 | (leave (G_ "key generation failed: ~a: ~a~%") |
554f26ec LC |
284 | (error-source err) |
285 | (error-string err))))) | |
286 | (public (find-sexp-token pair 'public-key)) | |
287 | (secret (find-sexp-token pair 'private-key))) | |
288 | ;; Create the following files as #o400. | |
289 | (umask #o266) | |
290 | ||
590e4154 | 291 | (mkdir-p (dirname %public-key-file)) |
554f26ec LC |
292 | (with-atomic-file-output %public-key-file |
293 | (lambda (port) | |
294 | (display (canonical-sexp->string public) port))) | |
295 | (with-atomic-file-output %private-key-file | |
296 | (lambda (port) | |
297 | (display (canonical-sexp->string secret) port))) | |
298 | ||
299 | ;; Make the public key readable by everyone. | |
300 | (chmod %public-key-file #o444))) | |
760c60d6 | 301 | |
f82cc5fd LC |
302 | (define (authorize-key) |
303 | "Authorize imports signed by the public key passed as an advanced sexp on | |
304 | the input port." | |
305 | (define (read-key) | |
306 | (catch 'gcry-error | |
307 | (lambda () | |
2535635f | 308 | (string->canonical-sexp (read-string (current-input-port)))) |
6ef3644e | 309 | (lambda (key proc err) |
69daee23 | 310 | (leave (G_ "failed to read public key: ~a: ~a~%") |
f82cc5fd LC |
311 | (error-source err) (error-string err))))) |
312 | ||
313 | (let ((key (read-key)) | |
314 | (acl (current-acl))) | |
315 | (unless (eq? 'public-key (canonical-sexp-nth-data key 0)) | |
69daee23 | 316 | (leave (G_ "s-expression does not denote a public key~%"))) |
f82cc5fd LC |
317 | |
318 | ;; Add KEY to the ACL and write that. | |
319 | (let ((acl (public-keys->acl (cons key (acl->public-keys acl))))) | |
de28fefd | 320 | (mkdir-p (dirname %acl-file)) |
f82cc5fd | 321 | (with-atomic-file-output %acl-file |
ded1012f | 322 | (cut write-acl acl <>))))) |
f82cc5fd | 323 | |
044277f6 LC |
324 | (define (list-contents port) |
325 | "Read a nar from PORT and print the list of files it contains to the current | |
326 | output port." | |
327 | (define (consume-input port size) | |
328 | (let ((bv (make-bytevector 32768))) | |
329 | (let loop ((total size)) | |
330 | (unless (zero? total) | |
331 | (let ((n (get-bytevector-n! port bv 0 | |
332 | (min total (bytevector-length bv))))) | |
333 | (loop (- total n))))))) | |
334 | ||
335 | (fold-archive (lambda (file type content result) | |
336 | (match type | |
337 | ('directory | |
338 | (format #t "D ~a~%" file)) | |
339 | ('symlink | |
340 | (format #t "S ~a -> ~a~%" file content)) | |
341 | ((or 'regular 'executable) | |
342 | (match content | |
343 | ((input . size) | |
344 | (format #t "~a ~60a ~10h B~%" | |
345 | (if (eq? type 'executable) | |
346 | "x" "r") | |
347 | file size) | |
348 | (consume-input input size)))))) | |
349 | #t | |
350 | port | |
351 | "")) | |
352 | ||
353 | \f | |
354 | ;;; | |
355 | ;;; Entry point. | |
356 | ;;; | |
357 | ||
3794ce93 LC |
358 | (define-command (guix-archive . args) |
359 | (category plumbing) | |
360 | (synopsis "manipulate, export, and import normalized archives (nars)") | |
361 | ||
87236aed LC |
362 | (define (lines port) |
363 | ;; Return lines read from PORT. | |
364 | (let loop ((line (read-line port)) | |
365 | (result '())) | |
366 | (if (eof-object? line) | |
367 | (reverse result) | |
368 | (loop (read-line port) | |
369 | (cons line result))))) | |
370 | ||
760c60d6 | 371 | (with-error-handling |
09238d61 LC |
372 | (let ((opts (parse-command-line args %options (list %default-options)))) |
373 | (parameterize ((%graft? (assoc-ref opts 'graft?))) | |
374 | (cond ((assoc-ref opts 'generate-key) | |
375 | => | |
376 | generate-key-pair) | |
377 | ((assoc-ref opts 'authorize) | |
378 | (authorize-key)) | |
379 | (else | |
380 | (with-status-verbosity (assoc-ref opts 'verbosity) | |
381 | (with-store store | |
382 | (set-build-options-from-command-line store opts) | |
2d5ee2c6 LC |
383 | (with-build-handler |
384 | (build-notifier #:use-substitutes? | |
385 | (assoc-ref opts 'substitutes?) | |
898e6d0a LC |
386 | #:verbosity |
387 | (assoc-ref opts 'verbosity) | |
2d5ee2c6 LC |
388 | #:dry-run? |
389 | (assoc-ref opts 'dry-run?)) | |
390 | (cond ((assoc-ref opts 'export) | |
391 | (export-from-store store opts)) | |
392 | ((assoc-ref opts 'import) | |
393 | (import-paths store (current-input-port))) | |
394 | ((assoc-ref opts 'missing) | |
395 | (let* ((files (lines (current-input-port))) | |
396 | (missing (remove (cut valid-path? store <>) | |
397 | files))) | |
398 | (format #t "~{~a~%~}" missing))) | |
399 | ((assoc-ref opts 'list) | |
400 | (list-contents (current-input-port))) | |
401 | ((assoc-ref opts 'extract) | |
402 | => | |
403 | (lambda (target) | |
404 | (restore-file (current-input-port) target))) | |
405 | (else | |
406 | (leave | |
407 | (G_ "either '--export' or '--import' \ | |
408 | must be specified~%"))))))))))))) |