You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

756 lines
32 KiB

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