1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (guix scripts archive)
20 #:use-module (guix config)
21 #:use-module (guix utils)
22 #:use-module ((guix build utils) #:select (mkdir-p))
23 #:use-module (guix store)
24 #:use-module (guix packages)
25 #:use-module (guix derivations)
26 #:use-module (guix monads)
27 #:use-module (guix ui)
28 #:use-module (guix pki)
29 #:use-module (guix pk-crypto)
30 #:use-module (guix scripts build)
31 #:use-module (gnu packages)
32 #:use-module (ice-9 match)
33 #:use-module (ice-9 format)
34 #:use-module (ice-9 rdelim)
35 #:use-module (srfi srfi-1)
36 #:use-module (srfi srfi-11)
37 #:use-module (srfi srfi-26)
38 #:use-module (srfi srfi-37)
39 #:use-module (rnrs io ports)
40 #:export (guix-archive))
44 ;;; Command-line options.
47 (define %default-options
48 ;; Alist of default option values.
49 `((system . ,(%current-system))
51 (max-silent-time . 3600)
55 (display (_ "Usage: guix archive [OPTION]... PACKAGE...
56 Export/import one or more packages from/to the store.\n"))
58 --export export the specified files/packages to stdout"))
60 -r, --recursive combined with '--export', include dependencies"))
62 --import import from the archive passed on stdin"))
64 --missing print the files from stdin that are missing"))
67 --generate-key[=PARAMETERS]
68 generate a key pair with the given parameters"))
70 --authorize authorize imports signed by the public key on stdin"))
73 -e, --expression=EXPR build the package or derivation EXPR evaluates to"))
75 -S, --source build the packages' source derivations"))
77 -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
79 --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
82 (show-build-options-help)
86 -h, --help display this help and exit"))
88 -V, --version display version information and exit"))
90 (show-bug-report-information))
92 (define %key-generation-parameters
93 ;; Default key generation parameters. We prefer Ed25519, but it was
94 ;; introduced in libgcrypt 1.6.0.
95 (if (version>? (gcrypt-version) "1.6.0")
96 "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))"
97 "(genkey (rsa (nbits 4:4096)))"))
100 ;; Specifications of the command-line options.
101 (cons* (option '(#\h "help") #f #f
105 (option '(#\V "version") #f #f
107 (show-version-and-exit "guix build")))
109 (option '("export") #f #f
110 (lambda (opt name arg result)
111 (alist-cons 'export #t result)))
112 (option '(#\r "recursive") #f #f
113 (lambda (opt name arg result)
114 (alist-cons 'export-recursive? #t result)))
115 (option '("import") #f #f
116 (lambda (opt name arg result)
117 (alist-cons 'import #t result)))
118 (option '("missing") #f #f
119 (lambda (opt name arg result)
120 (alist-cons 'missing #t result)))
121 (option '("generate-key") #f #t
122 (lambda (opt name arg result)
125 ;; XXX: Curve25519 was actually introduced in
128 (string->canonical-sexp
129 (or arg %key-generation-parameters))))
130 (alist-cons 'generate-key params result)))
131 (lambda (key proc err)
132 (leave (_ "invalid key generation parameters: ~a: ~a~%")
134 (error-string err))))))
135 (option '("authorize") #f #f
136 (lambda (opt name arg result)
137 (alist-cons 'authorize #t result)))
139 (option '(#\S "source") #f #f
140 (lambda (opt name arg result)
141 (alist-cons 'source? #t result)))
142 (option '(#\s "system") #t #f
143 (lambda (opt name arg result)
144 (alist-cons 'system arg
145 (alist-delete 'system result eq?))))
146 (option '("target") #t #f
147 (lambda (opt name arg result)
148 (alist-cons 'target arg
149 (alist-delete 'target result eq?))))
150 (option '(#\e "expression") #t #f
151 (lambda (opt name arg result)
152 (alist-cons 'expression arg result)))
153 (option '(#\n "dry-run") #f #f
154 (lambda (opt name arg result)
155 (alist-cons 'dry-run? #t result)))
157 %standard-build-options))
159 (define (derivation-from-expression store str package-derivation
161 "Read/eval STR and return the corresponding derivation path for SYSTEM.
162 When SOURCE? is true and STR evaluates to a package, return the derivation of
163 the package source; otherwise, use PACKAGE-DERIVATION to compute the
164 derivation of a package."
165 (match (read/eval str)
168 (let ((source (package-source p)))
170 (package-source-derivation store source)
171 (leave (_ "package `~a' has no source~%")
173 (package-derivation store p system)))
175 (run-with-store store
177 (set-guile-for-build (default-guile))
178 (proc)) #:system system))))
180 (define (options->derivations+files store opts)
181 "Given OPTS, the result of 'args-fold', return a list of derivations to
182 build and a list of store files to transfer."
183 (define package->derivation
184 (match (assoc-ref opts 'target)
185 (#f package-derivation)
187 (cut package-cross-derivation <> <> triplet <>))))
189 (define src? (assoc-ref opts 'source?))
190 (define sys (assoc-ref opts 'system))
192 (fold2 (lambda (arg derivations files)
195 (let ((drv (derivation-from-expression store str
198 (values (cons drv derivations)
199 (cons (derivation->output-path drv) files))))
200 (('argument . (? store-path? file))
201 (values derivations (cons file files)))
202 (('argument . (? string? spec))
203 (let-values (((p output)
204 (specification->package+output spec)))
206 (let* ((s (package-source p))
207 (drv (package-source-derivation store s)))
208 (values (cons drv derivations)
209 (cons (derivation->output-path drv)
211 (let ((drv (package->derivation store p sys)))
212 (values (cons drv derivations)
213 (cons (derivation->output-path drv output)
216 (values derivations files))))
226 (define (export-from-store store opts)
227 "Export the packages or derivations specified in OPTS from STORE. Write the
228 resulting archive to the standard output port."
229 (let-values (((drv files)
230 (options->derivations+files store opts)))
231 (set-build-options-from-command-line store opts)
232 (show-what-to-build store drv
233 #:use-substitutes? (assoc-ref opts 'substitutes?)
234 #:dry-run? (assoc-ref opts 'dry-run?))
236 (if (or (assoc-ref opts 'dry-run?)
237 (build-derivations store drv))
238 (export-paths store files (current-output-port)
239 #:recursive? (assoc-ref opts 'export-recursive?))
240 (leave (_ "unable to export the given packages~%")))))
242 (define (generate-key-pair parameters)
243 "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the
245 (when (or (file-exists? %public-key-file)
246 (file-exists? %private-key-file))
247 (leave (_ "key pair exists under '~a'; remove it first~%")
248 (dirname %public-key-file)))
250 (format (current-error-port)
251 (_ "Please wait while gathering entropy to generate the key pair;
252 this may take time...~%"))
254 (let* ((pair (catch 'gcry-error
256 (generate-key parameters))
257 (lambda (key proc err)
258 (leave (_ "key generation failed: ~a: ~a~%")
260 (error-string err)))))
261 (public (find-sexp-token pair 'public-key))
262 (secret (find-sexp-token pair 'private-key)))
263 ;; Create the following files as #o400.
266 (mkdir-p (dirname %public-key-file))
267 (with-atomic-file-output %public-key-file
269 (display (canonical-sexp->string public) port)))
270 (with-atomic-file-output %private-key-file
272 (display (canonical-sexp->string secret) port)))
274 ;; Make the public key readable by everyone.
275 (chmod %public-key-file #o444)))
277 (define (authorize-key)
278 "Authorize imports signed by the public key passed as an advanced sexp on
283 (string->canonical-sexp (get-string-all (current-input-port))))
284 (lambda (key proc err)
285 (leave (_ "failed to read public key: ~a: ~a~%")
286 (error-source err) (error-string err)))))
288 (let ((key (read-key))
290 (unless (eq? 'public-key (canonical-sexp-nth-data key 0))
291 (leave (_ "s-expression does not denote a public key~%")))
293 ;; Add KEY to the ACL and write that.
294 (let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
295 (mkdir-p (dirname %acl-file))
296 (with-atomic-file-output %acl-file
297 (cut write-acl acl <>)))))
299 (define (guix-archive . args)
301 ;; Return lines read from PORT.
302 (let loop ((line (read-line port))
304 (if (eof-object? line)
306 (loop (read-line port)
307 (cons line result)))))
310 ;; Ask for absolute file names so that .drv file names passed from the
311 ;; user to 'read-derivation' are absolute when it returns.
312 (with-fluids ((%file-port-name-canonicalization 'absolute))
313 (let ((opts (parse-command-line args %options (list %default-options))))
314 (cond ((assoc-ref opts 'generate-key)
317 ((assoc-ref opts 'authorize)
320 (let ((store (open-connection)))
321 (cond ((assoc-ref opts 'export)
322 (export-from-store store opts))
323 ((assoc-ref opts 'import)
324 (import-paths store (current-input-port)))
325 ((assoc-ref opts 'missing)
326 (let* ((files (lines (current-input-port)))
327 (missing (remove (cut valid-path? store <>)
329 (format #t "~{~a~%~}" missing)))
332 (_ "either '--export' or '--import' \
333 must be specified~%")))))))))))