Commit | Line | Data |
---|---|---|
760c60d6 | 1 | ;;; GNU Guix --- Functional package management for GNU |
f1de676e | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 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)) |
c6f8e9dd | 24 | #:use-module ((guix serialization) #:select (restore-file)) |
760c60d6 | 25 | #:use-module (guix store) |
2637cfd7 | 26 | #:use-module ((guix status) #:select (with-status-verbosity)) |
7573d30f | 27 | #:use-module (guix grafts) |
760c60d6 LC |
28 | #:use-module (guix packages) |
29 | #:use-module (guix derivations) | |
257b9341 | 30 | #:use-module (guix monads) |
760c60d6 | 31 | #:use-module (guix ui) |
554f26ec | 32 | #:use-module (guix pki) |
ca719424 | 33 | #:use-module (gcrypt pk-crypto) |
88981dd3 | 34 | #:use-module (guix scripts) |
84189ebc LC |
35 | #:use-module (guix scripts build) |
36 | #:use-module (gnu packages) | |
760c60d6 | 37 | #:use-module (ice-9 match) |
87236aed LC |
38 | #:use-module (ice-9 format) |
39 | #:use-module (ice-9 rdelim) | |
760c60d6 LC |
40 | #:use-module (srfi srfi-1) |
41 | #:use-module (srfi srfi-11) | |
42 | #:use-module (srfi srfi-26) | |
43 | #:use-module (srfi srfi-37) | |
2535635f | 44 | #:use-module (ice-9 binary-ports) |
f11c444d LC |
45 | #:export (guix-archive |
46 | options->derivations+files)) | |
760c60d6 LC |
47 | |
48 | \f | |
49 | ;;; | |
50 | ;;; Command-line options. | |
51 | ;;; | |
52 | ||
53 | (define %default-options | |
54 | ;; Alist of default option values. | |
b1edfbc3 | 55 | `((system . ,(%current-system)) |
760c60d6 | 56 | (substitutes? . #t) |
7920e187 | 57 | (build-hook? . #t) |
7573d30f | 58 | (graft? . #t) |
f1de676e LC |
59 | (print-build-trace? . #t) |
60 | (print-extended-build-trace? . #t) | |
61 | (multiplexed-build-output? . #t) | |
62 | (verbosity . 2) | |
63 | (debug . 0))) | |
760c60d6 LC |
64 | |
65 | (define (show-help) | |
69daee23 | 66 | (display (G_ "Usage: guix archive [OPTION]... PACKAGE... |
760c60d6 | 67 | Export/import one or more packages from/to the store.\n")) |
69daee23 | 68 | (display (G_ " |
760c60d6 | 69 | --export export the specified files/packages to stdout")) |
69daee23 | 70 | (display (G_ " |
56607088 | 71 | -r, --recursive combined with '--export', include dependencies")) |
69daee23 | 72 | (display (G_ " |
760c60d6 | 73 | --import import from the archive passed on stdin")) |
69daee23 | 74 | (display (G_ " |
87236aed | 75 | --missing print the files from stdin that are missing")) |
69daee23 | 76 | (display (G_ " |
c6f8e9dd | 77 | -x, --extract=DIR extract the archive on stdin to DIR")) |
760c60d6 | 78 | (newline) |
69daee23 | 79 | (display (G_ " |
554f26ec LC |
80 | --generate-key[=PARAMETERS] |
81 | generate a key pair with the given parameters")) | |
69daee23 | 82 | (display (G_ " |
36b56f08 LC |
83 | --authorize authorize imports signed by the public key on stdin")) |
84 | (newline) | |
69daee23 | 85 | (display (G_ " |
760c60d6 | 86 | -e, --expression=EXPR build the package or derivation EXPR evaluates to")) |
69daee23 | 87 | (display (G_ " |
760c60d6 | 88 | -S, --source build the packages' source derivations")) |
69daee23 | 89 | (display (G_ " |
760c60d6 | 90 | -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) |
69daee23 | 91 | (display (G_ " |
760c60d6 | 92 | --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) |
f1de676e LC |
93 | (display (G_ " |
94 | -v, --verbosity=LEVEL use the given verbosity LEVEL")) | |
e7fc17b5 LC |
95 | |
96 | (newline) | |
97 | (show-build-options-help) | |
98 | ||
760c60d6 | 99 | (newline) |
69daee23 | 100 | (display (G_ " |
760c60d6 | 101 | -h, --help display this help and exit")) |
69daee23 | 102 | (display (G_ " |
760c60d6 LC |
103 | -V, --version display version information and exit")) |
104 | (newline) | |
105 | (show-bug-report-information)) | |
106 | ||
1fda6840 LC |
107 | (define %key-generation-parameters |
108 | ;; Default key generation parameters. We prefer Ed25519, but it was | |
109 | ;; introduced in libgcrypt 1.6.0. | |
110 | (if (version>? (gcrypt-version) "1.6.0") | |
111 | "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))" | |
112 | "(genkey (rsa (nbits 4:4096)))")) | |
113 | ||
760c60d6 LC |
114 | (define %options |
115 | ;; Specifications of the command-line options. | |
e7fc17b5 LC |
116 | (cons* (option '(#\h "help") #f #f |
117 | (lambda args | |
118 | (show-help) | |
119 | (exit 0))) | |
120 | (option '(#\V "version") #f #f | |
121 | (lambda args | |
122 | (show-version-and-exit "guix build"))) | |
123 | ||
124 | (option '("export") #f #f | |
125 | (lambda (opt name arg result) | |
126 | (alist-cons 'export #t result))) | |
56607088 LC |
127 | (option '(#\r "recursive") #f #f |
128 | (lambda (opt name arg result) | |
129 | (alist-cons 'export-recursive? #t result))) | |
e7fc17b5 LC |
130 | (option '("import") #f #f |
131 | (lambda (opt name arg result) | |
132 | (alist-cons 'import #t result))) | |
133 | (option '("missing") #f #f | |
134 | (lambda (opt name arg result) | |
135 | (alist-cons 'missing #t result))) | |
c6f8e9dd LC |
136 | (option '("extract" #\x) #t #f |
137 | (lambda (opt name arg result) | |
138 | (alist-cons 'extract arg result))) | |
e7fc17b5 LC |
139 | (option '("generate-key") #f #t |
140 | (lambda (opt name arg result) | |
141 | (catch 'gcry-error | |
142 | (lambda () | |
1cbfce16 LC |
143 | ;; XXX: Curve25519 was actually introduced in |
144 | ;; libgcrypt 1.6.0. | |
e7fc17b5 LC |
145 | (let ((params |
146 | (string->canonical-sexp | |
1fda6840 | 147 | (or arg %key-generation-parameters)))) |
e7fc17b5 | 148 | (alist-cons 'generate-key params result))) |
6ef3644e | 149 | (lambda (key proc err) |
69daee23 | 150 | (leave (G_ "invalid key generation parameters: ~a: ~a~%") |
d0a85069 LC |
151 | (error-source err) |
152 | (error-string err)))))) | |
e7fc17b5 LC |
153 | (option '("authorize") #f #f |
154 | (lambda (opt name arg result) | |
155 | (alist-cons 'authorize #t result))) | |
156 | ||
157 | (option '(#\S "source") #f #f | |
158 | (lambda (opt name arg result) | |
159 | (alist-cons 'source? #t result))) | |
160 | (option '(#\s "system") #t #f | |
161 | (lambda (opt name arg result) | |
162 | (alist-cons 'system arg | |
163 | (alist-delete 'system result eq?)))) | |
164 | (option '("target") #t #f | |
165 | (lambda (opt name arg result) | |
166 | (alist-cons 'target arg | |
167 | (alist-delete 'target result eq?)))) | |
168 | (option '(#\e "expression") #t #f | |
169 | (lambda (opt name arg result) | |
170 | (alist-cons 'expression arg result))) | |
f1de676e LC |
171 | (option '(#\v "verbosity") #t #f |
172 | (lambda (opt name arg result) | |
173 | (let ((level (string->number* arg))) | |
174 | (alist-cons 'verbosity level | |
175 | (alist-delete 'verbosity result))))) | |
e7fc17b5 LC |
176 | (option '(#\n "dry-run") #f #f |
177 | (lambda (opt name arg result) | |
fd59105c | 178 | (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) |
e7fc17b5 LC |
179 | |
180 | %standard-build-options)) | |
760c60d6 | 181 | |
257b9341 LC |
182 | (define (derivation-from-expression store str package-derivation |
183 | system source?) | |
184 | "Read/eval STR and return the corresponding derivation path for SYSTEM. | |
185 | When SOURCE? is true and STR evaluates to a package, return the derivation of | |
186 | the package source; otherwise, use PACKAGE-DERIVATION to compute the | |
187 | derivation of a package." | |
188 | (match (read/eval str) | |
189 | ((? package? p) | |
190 | (if source? | |
191 | (let ((source (package-source p))) | |
192 | (if source | |
193 | (package-source-derivation store source) | |
69daee23 | 194 | (leave (G_ "package `~a' has no source~%") |
257b9341 LC |
195 | (package-name p)))) |
196 | (package-derivation store p system))) | |
197 | ((? procedure? proc) | |
e87f0591 LC |
198 | (run-with-store store |
199 | (mbegin %store-monad | |
200 | (set-guile-for-build (default-guile)) | |
201 | (proc)) #:system system)))) | |
257b9341 | 202 | |
760c60d6 LC |
203 | (define (options->derivations+files store opts) |
204 | "Given OPTS, the result of 'args-fold', return a list of derivations to | |
205 | build and a list of store files to transfer." | |
206 | (define package->derivation | |
207 | (match (assoc-ref opts 'target) | |
208 | (#f package-derivation) | |
209 | (triplet | |
210 | (cut package-cross-derivation <> <> triplet <>)))) | |
211 | ||
212 | (define src? (assoc-ref opts 'source?)) | |
213 | (define sys (assoc-ref opts 'system)) | |
214 | ||
215 | (fold2 (lambda (arg derivations files) | |
216 | (match arg | |
217 | (('expression . str) | |
218 | (let ((drv (derivation-from-expression store str | |
219 | package->derivation | |
220 | sys src?))) | |
221 | (values (cons drv derivations) | |
222 | (cons (derivation->output-path drv) files)))) | |
223 | (('argument . (? store-path? file)) | |
224 | (values derivations (cons file files))) | |
225 | (('argument . (? string? spec)) | |
226 | (let-values (((p output) | |
227 | (specification->package+output spec))) | |
228 | (if src? | |
229 | (let* ((s (package-source p)) | |
230 | (drv (package-source-derivation store s))) | |
231 | (values (cons drv derivations) | |
232 | (cons (derivation->output-path drv) | |
233 | files))) | |
234 | (let ((drv (package->derivation store p sys))) | |
235 | (values (cons drv derivations) | |
236 | (cons (derivation->output-path drv output) | |
237 | files)))))) | |
238 | (_ | |
239 | (values derivations files)))) | |
240 | '() | |
241 | '() | |
242 | opts)) | |
243 | ||
244 | \f | |
245 | ;;; | |
246 | ;;; Entry point. | |
247 | ;;; | |
248 | ||
249 | (define (export-from-store store opts) | |
250 | "Export the packages or derivations specified in OPTS from STORE. Write the | |
251 | resulting archive to the standard output port." | |
252 | (let-values (((drv files) | |
253 | (options->derivations+files store opts))) | |
254 | (show-what-to-build store drv | |
255 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
256 | #:dry-run? (assoc-ref opts 'dry-run?)) | |
257 | ||
760c60d6 LC |
258 | (if (or (assoc-ref opts 'dry-run?) |
259 | (build-derivations store drv)) | |
b1edfbc3 LC |
260 | (export-paths store files (current-output-port) |
261 | #:recursive? (assoc-ref opts 'export-recursive?)) | |
69daee23 | 262 | (leave (G_ "unable to export the given packages~%"))))) |
554f26ec LC |
263 | |
264 | (define (generate-key-pair parameters) | |
265 | "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the | |
266 | right place." | |
267 | (when (or (file-exists? %public-key-file) | |
268 | (file-exists? %private-key-file)) | |
69daee23 | 269 | (leave (G_ "key pair exists under '~a'; remove it first~%") |
554f26ec LC |
270 | (dirname %public-key-file))) |
271 | ||
272 | (format (current-error-port) | |
69daee23 | 273 | (G_ "Please wait while gathering entropy to generate the key pair; |
554f26ec LC |
274 | this may take time...~%")) |
275 | ||
276 | (let* ((pair (catch 'gcry-error | |
277 | (lambda () | |
278 | (generate-key parameters)) | |
6ef3644e | 279 | (lambda (key proc err) |
69daee23 | 280 | (leave (G_ "key generation failed: ~a: ~a~%") |
554f26ec LC |
281 | (error-source err) |
282 | (error-string err))))) | |
283 | (public (find-sexp-token pair 'public-key)) | |
284 | (secret (find-sexp-token pair 'private-key))) | |
285 | ;; Create the following files as #o400. | |
286 | (umask #o266) | |
287 | ||
590e4154 | 288 | (mkdir-p (dirname %public-key-file)) |
554f26ec LC |
289 | (with-atomic-file-output %public-key-file |
290 | (lambda (port) | |
291 | (display (canonical-sexp->string public) port))) | |
292 | (with-atomic-file-output %private-key-file | |
293 | (lambda (port) | |
294 | (display (canonical-sexp->string secret) port))) | |
295 | ||
296 | ;; Make the public key readable by everyone. | |
297 | (chmod %public-key-file #o444))) | |
760c60d6 | 298 | |
f82cc5fd LC |
299 | (define (authorize-key) |
300 | "Authorize imports signed by the public key passed as an advanced sexp on | |
301 | the input port." | |
302 | (define (read-key) | |
303 | (catch 'gcry-error | |
304 | (lambda () | |
2535635f | 305 | (string->canonical-sexp (read-string (current-input-port)))) |
6ef3644e | 306 | (lambda (key proc err) |
69daee23 | 307 | (leave (G_ "failed to read public key: ~a: ~a~%") |
f82cc5fd LC |
308 | (error-source err) (error-string err))))) |
309 | ||
310 | (let ((key (read-key)) | |
311 | (acl (current-acl))) | |
312 | (unless (eq? 'public-key (canonical-sexp-nth-data key 0)) | |
69daee23 | 313 | (leave (G_ "s-expression does not denote a public key~%"))) |
f82cc5fd LC |
314 | |
315 | ;; Add KEY to the ACL and write that. | |
316 | (let ((acl (public-keys->acl (cons key (acl->public-keys acl))))) | |
de28fefd | 317 | (mkdir-p (dirname %acl-file)) |
f82cc5fd | 318 | (with-atomic-file-output %acl-file |
ded1012f | 319 | (cut write-acl acl <>))))) |
f82cc5fd | 320 | |
760c60d6 | 321 | (define (guix-archive . args) |
87236aed LC |
322 | (define (lines port) |
323 | ;; Return lines read from PORT. | |
324 | (let loop ((line (read-line port)) | |
325 | (result '())) | |
326 | (if (eof-object? line) | |
327 | (reverse result) | |
328 | (loop (read-line port) | |
329 | (cons line result))))) | |
330 | ||
760c60d6 LC |
331 | (with-error-handling |
332 | ;; Ask for absolute file names so that .drv file names passed from the | |
333 | ;; user to 'read-derivation' are absolute when it returns. | |
334 | (with-fluids ((%file-port-name-canonicalization 'absolute)) | |
b3f21389 | 335 | (let ((opts (parse-command-line args %options (list %default-options)))) |
7573d30f LC |
336 | (parameterize ((%graft? (assoc-ref opts 'graft?))) |
337 | (cond ((assoc-ref opts 'generate-key) | |
338 | => | |
339 | generate-key-pair) | |
340 | ((assoc-ref opts 'authorize) | |
341 | (authorize-key)) | |
342 | (else | |
f1de676e LC |
343 | (with-status-verbosity (assoc-ref opts 'verbosity) |
344 | (with-store store | |
345 | (set-build-options-from-command-line store opts) | |
346 | (cond ((assoc-ref opts 'export) | |
347 | (export-from-store store opts)) | |
348 | ((assoc-ref opts 'import) | |
349 | (import-paths store (current-input-port))) | |
350 | ((assoc-ref opts 'missing) | |
351 | (let* ((files (lines (current-input-port))) | |
352 | (missing (remove (cut valid-path? store <>) | |
353 | files))) | |
354 | (format #t "~{~a~%~}" missing))) | |
355 | ((assoc-ref opts 'extract) | |
356 | => | |
357 | (lambda (target) | |
358 | (restore-file (current-input-port) target))) | |
359 | (else | |
360 | (leave | |
361 | (G_ "either '--export' or '--import' \ | |
362 | must be specified~%"))))))))))))) |