| blob | ed876b25920e0b9042c3f4066a8a7524ac86c5be |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
4 ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
5 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
6 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
7 ;;;
8 ;;; This file is part of GNU Guix.
9 ;;;
10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
11 ;;; under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or (at
13 ;;; your option) any later version.
14 ;;;
15 ;;; GNU Guix is distributed in the hope that it will be useful, but
16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
23 (define-module (guix scripts pack)
24 #:use-module (guix scripts)
25 #:use-module (guix ui)
26 #:use-module (guix gexp)
27 #:use-module (guix utils)
28 #:use-module (guix store)
29 #:use-module (guix grafts)
30 #:use-module (guix monads)
31 #:use-module (guix modules)
32 #:use-module (guix packages)
33 #:use-module (guix profiles)
34 #:use-module (guix derivations)
35 #:use-module (guix search-paths)
36 #:use-module (guix build-system gnu)
37 #:use-module (guix scripts build)
38 #:use-module ((guix self) #:select (make-config.scm))
39 #:use-module (gnu packages)
40 #:use-module (gnu packages bootstrap)
41 #:use-module (gnu packages compression)
42 #:use-module (gnu packages guile)
43 #:use-module (gnu packages base)
44 #:autoload (gnu packages package-management) (guix)
45 #:autoload (gnu packages gnupg) (libgcrypt)
46 #:autoload (gnu packages guile) (guile2.0-json guile-json)
47 #:use-module (srfi srfi-1)
48 #:use-module (srfi srfi-9)
49 #:use-module (srfi srfi-26)
50 #:use-module (srfi srfi-37)
51 #:use-module (ice-9 match)
52 #:export (compressor?
53 lookup-compressor
54 self-contained-tarball
55 guix-pack))
57 ;; Type of a compression tool.
58 (define-record-type <compressor>
59 (compressor name extension command)
60 compressor?
61 (name compressor-name) ;string (e.g., "gzip")
62 (extension compressor-extension) ;string (e.g., ".lz")
63 (command compressor-command)) ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n"))
65 (define %compressors
66 ;; Available compression tools.
67 (list (compressor "gzip" ".gz"
68 #~(#+(file-append gzip "/bin/gzip") "-9n"))
69 (compressor "lzip" ".lz"
70 #~(#+(file-append lzip "/bin/lzip") "-9"))
71 (compressor "xz" ".xz"
72 #~(#+(file-append xz "/bin/xz") "-e -T0"))
73 (compressor "bzip2" ".bz2"
74 #~(#+(file-append bzip2 "/bin/bzip2") "-9"))
75 (compressor "none" "" #f)))
77 ;; This one is only for use in this module, so don't put it in %compressors.
78 (define bootstrap-xz
79 (compressor "bootstrap-xz" ".xz"
80 #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e -T0")))
82 (define (lookup-compressor name)
83 "Return the compressor object called NAME. Error out if it could not be
84 found."
85 (or (find (match-lambda
86 (($ <compressor> name*)
87 (string=? name* name)))
88 %compressors)
89 (leave (G_ "~a: compressor not found~%") name)))
91 (define* (self-contained-tarball name profile
92 #:key target
93 deduplicate?
94 (compressor (first %compressors))
95 localstatedir?
96 (symlinks '())
97 (archiver tar))
98 "Return a self-contained tarball containing a store initialized with the
99 closure of PROFILE, a derivation. The tarball contains /gnu/store; if
100 LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db
101 with a properly initialized store database.
103 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
104 added to the pack."
105 (define not-config?
106 (match-lambda
107 (('guix 'config) #f)
108 (('guix _ ...) #t)
109 (('gnu _ ...) #t)
110 (_ #f)))
112 (define libgcrypt
113 (module-ref (resolve-interface '(gnu packages gnupg))
114 'libgcrypt))
116 (define schema
117 (and localstatedir?
118 (local-file (search-path %load-path
119 "guix/store/schema.sql"))))
121 (define build
122 (with-imported-modules `(((guix config)
123 => ,(make-config.scm
124 #:libgcrypt libgcrypt))
125 ,@(source-module-closure
126 `((guix build utils)
127 (guix build union)
128 (guix build store-copy)
129 (gnu build install))
130 #:select? not-config?))
131 (with-extensions (cons guile-sqlite3
132 (package-transitive-propagated-inputs
133 guile-sqlite3))
134 #~(begin
135 (use-modules (guix build utils)
136 ((guix build union) #:select (relative-file-name))
137 (gnu build install)
138 (srfi srfi-1)
139 (srfi srfi-26)
140 (ice-9 match))
142 (define %root "root")
144 (define symlink->directives
145 ;; Return "populate directives" to make the given symlink and its
146 ;; parent directories.
147 (match-lambda
148 ((source '-> target)
149 (let ((target (string-append #$profile "/" target))
150 (parent (dirname source)))
151 ;; Never add a 'directory' directive for "/" so as to
152 ;; preserve its ownnership when extracting the archive (see
153 ;; below), and also because this would lead to adding the
154 ;; same entries twice in the tarball.
155 `(,@(if (string=? parent "/")
156 '()
157 `((directory ,parent)))
158 (,source
159 -> ,(relative-file-name parent target)))))))
161 (define directives
162 ;; Fully-qualified symlinks.
163 (append-map symlink->directives '#$symlinks))
165 ;; The --sort option was added to GNU tar in version 1.28, released
166 ;; 2014-07-28. For testing, we use the bootstrap tar, which is
167 ;; older and doesn't support it.
168 (define tar-supports-sort?
169 (zero? (system* (string-append #+archiver "/bin/tar")
170 "cf" "/dev/null" "--files-from=/dev/null"
171 "--sort=name")))
173 ;; Add 'tar' to the search path.
174 (setenv "PATH" #+(file-append archiver "/bin"))
176 ;; Note: there is not much to gain here with deduplication and there
177 ;; is the overhead of the '.links' directory, so turn it off.
178 ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
179 ;; with hard links:
180 ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
181 (populate-single-profile-directory %root
182 #:profile #$profile
183 #:closure "profile"
184 #:deduplicate? #f
185 #:register? #$localstatedir?
186 #:schema #$schema)
188 ;; Create SYMLINKS.
189 (for-each (cut evaluate-populate-directive <> %root)
190 directives)
192 ;; Create the tarball. Use GNU format so there's no file name
193 ;; length limitation.
194 (with-directory-excursion %root
195 (exit
196 (zero? (apply system* "tar"
197 "-I"
198 (string-join '#+(compressor-command compressor))
199 "--format=gnu"
201 ;; Avoid non-determinism in the archive. Use
202 ;; mtime = 1, not zero, because that is what the
203 ;; daemon does for files in the store (see the
204 ;; 'mtimeStore' constant in local-store.cc.)
205 (if tar-supports-sort? "--sort=name" "--mtime=@1")
206 "--mtime=@1" ;for files in /var/guix
207 "--owner=root:0"
208 "--group=root:0"
210 "--check-links"
211 "-cvf" #$output
212 ;; Avoid adding / and /var to the tarball, so
213 ;; that the ownership and permissions of those
214 ;; directories will not be overwritten when
215 ;; extracting the archive. Do not include /root
216 ;; because the root account might have a
217 ;; different home directory.
218 #$@(if localstatedir?
219 '("./var/guix")
220 '())
222 (string-append "." (%store-directory))
224 (delete-duplicates
225 (filter-map (match-lambda
226 (('directory directory)
227 (string-append "." directory))
228 ((source '-> _)
229 (string-append "." source))
230 (_ #f))
231 directives))))))))))
233 (gexp->derivation (string-append name ".tar"
234 (compressor-extension compressor))
235 build
236 #:references-graphs `(("profile" ,profile))))
238 (define* (squashfs-image name profile
239 #:key target
240 deduplicate?
241 (compressor (first %compressors))
242 localstatedir?
243 (symlinks '())
244 (archiver squashfs-tools-next))
245 "Return a squashfs image containing a store initialized with the closure of
246 PROFILE, a derivation. The image contains a subset of /gnu/store, empty mount
247 points for virtual file systems (like procfs), and optional symlinks.
249 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
250 added to the pack."
251 (define build
252 (with-imported-modules '((guix build utils)
253 (guix build store-copy)
254 (gnu build install))
255 #~(begin
256 (use-modules (guix build utils)
257 (gnu build install)
258 (guix build store-copy)
259 (srfi srfi-1)
260 (srfi srfi-26)
261 (ice-9 match))
263 (setenv "PATH" (string-append #$archiver "/bin"))
265 ;; We need an empty file in order to have a valid file argument when
266 ;; we reparent the root file system. Read on for why that's
267 ;; necessary.
268 (with-output-to-file ".empty" (lambda () (display "")))
270 ;; Create the squashfs image in several steps.
271 ;; Add all store items. Unfortunately mksquashfs throws away all
272 ;; ancestor directories and only keeps the basename. We fix this
273 ;; in the following invocations of mksquashfs.
274 (apply invoke "mksquashfs"
275 `(,@(map store-info-item
276 (call-with-input-file "profile"
277 read-reference-graph))
278 ,#$output
280 ;; Do not perform duplicate checking because we
281 ;; don't have any dupes.
282 "-no-duplicates"
283 "-comp"
284 ,#+(compressor-name compressor)))
286 ;; Here we reparent the store items. For each sub-directory of
287 ;; the store prefix we need one invocation of "mksquashfs".
288 (for-each (lambda (dir)
289 (apply invoke "mksquashfs"
290 `(".empty"
291 ,#$output
292 "-root-becomes" ,dir)))
293 (reverse (string-tokenize (%store-directory)
294 (char-set-complement (char-set #\/)))))
296 ;; Add symlinks and mount points.
297 (apply invoke "mksquashfs"
298 `(".empty"
299 ,#$output
300 ;; Create SYMLINKS via pseudo file definitions.
301 ,@(append-map
302 (match-lambda
303 ((source '-> target)
304 (list "-p"
305 (string-join
306 ;; name s mode uid gid symlink
307 (list source
308 "s" "777" "0" "0"
309 (string-append #$profile "/" target))))))
310 '#$symlinks)
312 ;; Create empty mount points.
313 "-p" "/proc d 555 0 0"
314 "-p" "/sys d 555 0 0"
315 "-p" "/dev d 555 0 0")))))
317 (gexp->derivation (string-append name
318 (compressor-extension compressor)
319 ".squashfs")
320 build
321 #:references-graphs `(("profile" ,profile))))
323 (define* (docker-image name profile
324 #:key target
325 deduplicate?
326 (compressor (first %compressors))
327 localstatedir?
328 (symlinks '())
329 (archiver tar))
330 "Return a derivation to construct a Docker image of PROFILE. The
331 image is a tarball conforming to the Docker Image Specification, compressed
332 with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it
333 must a be a GNU triplet and it is used to derive the architecture metadata in
334 the image."
335 ;; FIXME: Honor LOCALSTATEDIR?.
336 (define not-config?
337 (match-lambda
338 (('guix 'config) #f)
339 (('guix rest ...) #t)
340 (('gnu rest ...) #t)
341 (rest #f)))
343 (define defmod 'define-module) ;trick Geiser
345 (define config
346 ;; (guix config) module for consumption by (guix gcrypt).
347 (scheme-file "gcrypt-config.scm"
348 #~(begin
349 (#$defmod (guix config)
350 #:export (%libgcrypt))
352 ;; XXX: Work around <http://bugs.gnu.org/15602>.
353 (eval-when (expand load eval)
354 (define %libgcrypt
355 #+(file-append libgcrypt "/lib/libgcrypt"))))))
357 (define json
358 ;; Pick the guile-json package that corresponds to the Guile used to build
359 ;; derivations.
360 (if (string-prefix? "2.0" (package-version (default-guile)))
361 guile2.0-json
362 guile-json))
364 (define build
365 ;; Guile-JSON is required by (guix docker).
366 (with-extensions (list json)
367 (with-imported-modules `(,@(source-module-closure '((guix docker))
368 #:select? not-config?)
369 (guix build store-copy)
370 ((guix config) => ,config))
371 #~(begin
372 (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
374 (setenv "PATH" (string-append #$archiver "/bin"))
376 (build-docker-image #$output
377 (map store-info-item
378 (call-with-input-file "profile"
379 read-reference-graph))
380 #$profile
381 #:system (or #$target (utsname:machine (uname)))
382 #:symlinks '#$symlinks
383 #:compressor '#$(compressor-command compressor)
384 #:creation-time (make-time time-utc 0 1))))))
386 (gexp->derivation (string-append name ".tar"
387 (compressor-extension compressor))
388 build
389 #:references-graphs `(("profile" ,profile))))
391 \f
392 ;;;
393 ;;; Compiling C programs.
394 ;;;
396 ;; A C compiler. That lowers to a single program that can be passed typical C
397 ;; compiler flags, and it makes sure the whole toolchain is available.
398 (define-record-type <c-compiler>
399 (%c-compiler toolchain guile)
400 c-compiler?
401 (toolchain c-compiler-toolchain)
402 (guile c-compiler-guile))
404 (define* (c-compiler #:optional inputs
405 #:key (guile (default-guile)))
406 (%c-compiler inputs guile))
408 (define (bootstrap-c-compiler)
409 "Return the C compiler that uses the bootstrap toolchain. This is used only
410 by '--bootstrap', for testing purposes."
411 (define bootstrap-toolchain
412 (list (first (assoc-ref %bootstrap-inputs "gcc"))
413 (first (assoc-ref %bootstrap-inputs "binutils"))
414 (first (assoc-ref %bootstrap-inputs "libc"))))
416 (c-compiler bootstrap-toolchain
417 #:guile %bootstrap-guile))
419 (define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target)
420 "Lower COMPILER to a single script that does the right thing."
421 (define toolchain
422 (or (c-compiler-toolchain compiler)
423 (list (first (assoc-ref (standard-packages) "gcc"))
424 (first (assoc-ref (standard-packages) "ld-wrapper"))
425 (first (assoc-ref (standard-packages) "binutils"))
426 (first (assoc-ref (standard-packages) "libc"))
427 (gexp-input (first (assoc-ref (standard-packages) "libc"))
428 "static"))))
430 (define inputs
431 (match (append-map package-propagated-inputs
432 (filter package? toolchain))
433 (((labels things . _) ...)
434 (append toolchain things))))
436 (define search-paths
437 (cons $PATH
438 (append-map package-native-search-paths
439 (filter package? inputs))))
441 (define run
442 (with-imported-modules (source-module-closure
443 '((guix build utils)
444 (guix search-paths)))
445 #~(begin
446 (use-modules (guix build utils) (guix search-paths)
447 (ice-9 match))
449 (define (output-file args)
450 (let loop ((args args))
451 (match args
452 (() "a.out")
453 (("-o" file _ ...) file)
454 ((head rest ...) (loop rest)))))
456 (set-search-paths (map sexp->search-path-specification
457 '#$(map search-path-specification->sexp
458 search-paths))
459 '#$inputs)
461 (let ((output (output-file (command-line))))
462 (apply invoke "gcc" (cdr (command-line)))
463 (invoke "strip" output)))))
465 (when target
466 ;; TODO: Yep, we'll have to do it someday!
467 (leave (G_ "cross-compilation not implemented here;
468 please email '~a'~%")
469 (@ (guix config) %guix-bug-report-address)))
471 (gexp->script "c-compiler" run
472 #:guile (c-compiler-guile compiler)))
474 \f
475 ;;;
476 ;;; Wrapped package.
477 ;;;
479 (define* (wrapped-package package
480 #:optional (compiler (c-compiler)))
481 (define runner
482 (local-file (search-auxiliary-file "run-in-namespace.c")))
484 (define build
485 (with-imported-modules (source-module-closure
486 '((guix build utils)
487 (guix build union)))
488 #~(begin
489 (use-modules (guix build utils)
490 ((guix build union) #:select (relative-file-name))
491 (ice-9 ftw)
492 (ice-9 match))
494 (define (strip-store-prefix file)
495 ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
496 ;; "/bin/foo".
497 (let* ((len (string-length (%store-directory)))
498 (base (string-drop file (+ 1 len))))
499 (match (string-index base #\/)
500 (#f base)
501 (index (string-drop base index)))))
503 (define (build-wrapper program)
504 ;; Build a user-namespace wrapper for PROGRAM.
505 (format #t "building wrapper for '~a'...~%" program)
506 (copy-file #$runner "run.c")
508 (substitute* "run.c"
509 (("@WRAPPED_PROGRAM@") program)
510 (("@STORE_DIRECTORY@") (%store-directory)))
512 (let* ((base (strip-store-prefix program))
513 (result (string-append #$output "/" base)))
514 (mkdir-p (dirname result))
515 (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
516 "run.c" "-o" result)
517 (delete-file "run.c")))
519 (setvbuf (current-output-port)
520 (cond-expand (guile-2.2 'line)
521 (else _IOLBF)))
523 ;; Link the top-level files of PACKAGE so that search paths are
524 ;; properly defined in PROFILE/etc/profile.
525 (mkdir #$output)
526 (for-each (lambda (file)
527 (unless (member file '("." ".." "bin" "sbin" "libexec"))
528 (let ((file* (string-append #$package "/" file)))
529 (symlink (relative-file-name #$output file*)
530 (string-append #$output "/" file)))))
531 (scandir #$package))
533 (for-each build-wrapper
534 (append (find-files #$(file-append package "/bin"))
535 (find-files #$(file-append package "/sbin"))
536 (find-files #$(file-append package "/libexec")))))))
538 (computed-file (string-append (package-full-name package "-") "R")
539 build))
541 (define (map-manifest-entries proc manifest)
542 "Apply PROC to all the entries of MANIFEST and return a new manifest."
543 (make-manifest
544 (map (lambda (entry)
545 (manifest-entry
546 (inherit entry)
547 (item (proc (manifest-entry-item entry)))))
548 (manifest-entries manifest))))
550 \f
551 ;;;
552 ;;; Command-line options.
553 ;;;
555 (define %default-options
556 ;; Alist of default option values.
557 `((format . tarball)
558 (system . ,(%current-system))
559 (substitutes? . #t)
560 (build-hook? . #t)
561 (graft? . #t)
562 (verbosity . 0)
563 (symlinks . ())
564 (compressor . ,(first %compressors))))
566 (define %formats
567 ;; Supported pack formats.
568 `((tarball . ,self-contained-tarball)
569 (squashfs . ,squashfs-image)
570 (docker . ,docker-image)))
572 (define %options
573 ;; Specifications of the command-line options.
574 (cons* (option '(#\h "help") #f #f
575 (lambda args
576 (show-help)
577 (exit 0)))
578 (option '(#\V "version") #f #f
579 (lambda args
580 (show-version-and-exit "guix pack")))
582 (option '(#\n "dry-run") #f #f
583 (lambda (opt name arg result)
584 (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
585 (option '(#\f "format") #t #f
586 (lambda (opt name arg result)
587 (alist-cons 'format (string->symbol arg) result)))
588 (option '(#\R "relocatable") #f #f
589 (lambda (opt name arg result)
590 (alist-cons 'relocatable? #t result)))
591 (option '(#\e "expression") #t #f
592 (lambda (opt name arg result)
593 (alist-cons 'expression arg result)))
594 (option '(#\m "manifest") #t #f
595 (lambda (opt name arg result)
596 (alist-cons 'manifest arg result)))
597 (option '(#\s "system") #t #f
598 (lambda (opt name arg result)
599 (alist-cons 'system arg
600 (alist-delete 'system result eq?))))
601 (option '("target") #t #f
602 (lambda (opt name arg result)
603 (alist-cons 'target arg
604 (alist-delete 'target result eq?))))
605 (option '(#\C "compression") #t #f
606 (lambda (opt name arg result)
607 (alist-cons 'compressor (lookup-compressor arg)
608 result)))
609 (option '(#\S "symlink") #t #f
610 (lambda (opt name arg result)
611 ;; Note: Using 'string-split' allows us to handle empty
612 ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is
613 ;; a symlink to the profile) correctly.
614 (match (string-split arg (char-set #\=))
615 ((source target)
616 (let ((symlinks (assoc-ref result 'symlinks)))
617 (alist-cons 'symlinks
618 `((,source -> ,target) ,@symlinks)
619 (alist-delete 'symlinks result eq?))))
620 (x
621 (leave (G_ "~a: invalid symlink specification~%")
622 arg)))))
623 (option '("localstatedir") #f #f
624 (lambda (opt name arg result)
625 (alist-cons 'localstatedir? #t result)))
626 (option '("bootstrap") #f #f
627 (lambda (opt name arg result)
628 (alist-cons 'bootstrap? #t result)))
630 (append %transformation-options
631 %standard-build-options)))
633 (define (show-help)
634 (display (G_ "Usage: guix pack [OPTION]... PACKAGE...
635 Create a bundle of PACKAGE.\n"))
636 (show-build-options-help)
637 (newline)
638 (show-transformation-options-help)
639 (newline)
640 (display (G_ "
641 -f, --format=FORMAT build a pack in the given FORMAT"))
642 (display (G_ "
643 -R, --relocatable produce relocatable executables"))
644 (display (G_ "
645 -e, --expression=EXPR consider the package EXPR evaluates to"))
646 (display (G_ "
647 -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
648 (display (G_ "
649 --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
650 (display (G_ "
651 -C, --compression=TOOL compress using TOOL--e.g., \"lzip\""))
652 (display (G_ "
653 -S, --symlink=SPEC create symlinks to the profile according to SPEC"))
654 (display (G_ "
655 -m, --manifest=FILE create a pack with the manifest from FILE"))
656 (display (G_ "
657 --localstatedir include /var/guix in the resulting pack"))
658 (display (G_ "
659 --bootstrap use the bootstrap binaries to build the pack"))
660 (newline)
661 (display (G_ "
662 -h, --help display this help and exit"))
663 (display (G_ "
664 -V, --version display version information and exit"))
665 (newline)
666 (show-bug-report-information))
668 \f
669 ;;;
670 ;;; Entry point.
671 ;;;
673 (define (guix-pack . args)
674 (define opts
675 (parse-command-line args %options (list %default-options)))
677 (define maybe-package-argument
678 ;; Given an option pair, return a package, a package/output tuple, or #f.
679 (match-lambda
680 (('argument . spec)
681 (call-with-values
682 (lambda ()
683 (specification->package+output spec))
684 list))
685 (('expression . exp)
686 (read/eval-package-expression exp))
687 (x #f)))
689 (define (manifest-from-args store opts)
690 (let* ((transform (options->transformation opts))
691 (packages (map (match-lambda
692 (((? package? package) output)
693 (list (transform store package) output))
694 ((? package? package)
695 (list (transform store package) "out")))
696 (filter-map maybe-package-argument opts)))
697 (manifest-file (assoc-ref opts 'manifest)))
698 (cond
699 ((and manifest-file (not (null? packages)))
700 (leave (G_ "both a manifest and a package list were given~%")))
701 (manifest-file
702 (let ((user-module (make-user-module '((guix profiles) (gnu)))))
703 (load* manifest-file user-module)))
704 (else (packages->manifest packages)))))
706 (with-error-handling
707 (with-store store
708 ;; Set the build options before we do anything else.
709 (set-build-options-from-command-line store opts)
711 (parameterize ((%graft? (assoc-ref opts 'graft?))
712 (%guile-for-build (package-derivation
713 store
714 (if (assoc-ref opts 'bootstrap?)
715 %bootstrap-guile
716 (canonical-package guile-2.2))
717 #:graft? (assoc-ref opts 'graft?))))
718 (let* ((dry-run? (assoc-ref opts 'dry-run?))
719 (relocatable? (assoc-ref opts 'relocatable?))
720 (manifest (let ((manifest (manifest-from-args store opts)))
721 ;; Note: We cannot honor '--bootstrap' here because
722 ;; 'glibc-bootstrap' lacks 'libc.a'.
723 (if relocatable?
724 (map-manifest-entries wrapped-package manifest)
725 manifest)))
726 (pack-format (assoc-ref opts 'format))
727 (name (string-append (symbol->string pack-format)
728 "-pack"))
729 (target (assoc-ref opts 'target))
730 (bootstrap? (assoc-ref opts 'bootstrap?))
731 (compressor (if bootstrap?
732 bootstrap-xz
733 (assoc-ref opts 'compressor)))
734 (archiver (if (equal? pack-format 'squashfs)
735 squashfs-tools-next
736 (if bootstrap?
737 %bootstrap-coreutils&co
738 tar)))
739 (symlinks (assoc-ref opts 'symlinks))
740 (build-image (match (assq-ref %formats pack-format)
741 ((? procedure? proc) proc)
742 (#f
743 (leave (G_ "~a: unknown pack format")
744 format))))
745 (localstatedir? (assoc-ref opts 'localstatedir?)))
746 (run-with-store store
747 (mlet* %store-monad ((profile (profile-derivation
748 manifest
749 #:relative-symlinks? relocatable?
750 #:hooks (if bootstrap?
751 '()
752 %default-profile-hooks)
753 #:locales? (not bootstrap?)
754 #:target target))
755 (drv (build-image name profile
756 #:target
757 target
758 #:compressor
759 compressor
760 #:symlinks
761 symlinks
762 #:localstatedir?
763 localstatedir?
764 #:archiver
765 archiver)))
766 (mbegin %store-monad
767 (show-what-to-build* (list drv)
768 #:use-substitutes?
769 (assoc-ref opts 'substitutes?)
770 #:dry-run? dry-run?)
771 (munless dry-run?
772 (built-derivations (list drv))
773 (return (format #t "~a~%"
774 (derivation->output-path drv))))))
775 #:system (assoc-ref opts 'system)))))))