pack.scm 55 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 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. ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
  7. ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
  8. ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
  9. ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
  10. ;;;
  11. ;;; This file is part of GNU Guix.
  12. ;;;
  13. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  14. ;;; under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 3 of the License, or (at
  16. ;;; your option) any later version.
  17. ;;;
  18. ;;; GNU Guix is distributed in the hope that it will be useful, but
  19. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  25. (define-module (guix scripts pack)
  26. #:use-module (guix scripts)
  27. #:use-module (guix ui)
  28. #:use-module (guix gexp)
  29. #:use-module ((guix build utils) #:select (%xz-parallel-args))
  30. #:use-module (guix utils)
  31. #:use-module (guix store)
  32. #:use-module ((guix status) #:select (with-status-verbosity))
  33. #:use-module ((guix self) #:select (make-config.scm))
  34. #:use-module (guix grafts)
  35. #:autoload (guix inferior) (inferior-package?
  36. inferior-package-name
  37. inferior-package-version)
  38. #:use-module (guix monads)
  39. #:use-module (guix modules)
  40. #:use-module (guix packages)
  41. #:use-module (guix profiles)
  42. #:use-module (guix describe)
  43. #:use-module (guix derivations)
  44. #:use-module (guix search-paths)
  45. #:use-module (guix build-system gnu)
  46. #:use-module (guix scripts build)
  47. #:use-module (guix transformations)
  48. #:use-module ((guix self) #:select (make-config.scm))
  49. #:use-module (gnu packages)
  50. #:use-module (gnu packages bootstrap)
  51. #:use-module ((gnu packages compression) #:hide (zip))
  52. #:use-module (gnu packages guile)
  53. #:use-module (gnu packages base)
  54. #:autoload (gnu packages package-management) (guix)
  55. #:autoload (gnu packages gnupg) (guile-gcrypt)
  56. #:autoload (gnu packages guile) (guile2.0-json guile-json)
  57. #:use-module (srfi srfi-1)
  58. #:use-module (srfi srfi-9)
  59. #:use-module (srfi srfi-26)
  60. #:use-module (srfi srfi-37)
  61. #:use-module (ice-9 match)
  62. #:export (compressor?
  63. compressor-name
  64. compressor-extenstion
  65. compressor-command
  66. %compressors
  67. lookup-compressor
  68. self-contained-tarball
  69. docker-image
  70. squashfs-image
  71. %formats
  72. guix-pack))
  73. ;; Type of a compression tool.
  74. (define-record-type <compressor>
  75. (compressor name extension command)
  76. compressor?
  77. (name compressor-name) ;string (e.g., "gzip")
  78. (extension compressor-extension) ;string (e.g., ".lz")
  79. (command compressor-command)) ;gexp (e.g., #~(list "/gnu/store/…/gzip"
  80. ; "-9n" ))
  81. (define %compressors
  82. ;; Available compression tools.
  83. (list (compressor "gzip" ".gz"
  84. #~(list #+(file-append gzip "/bin/gzip") "-9n"))
  85. (compressor "lzip" ".lz"
  86. #~(list #+(file-append lzip "/bin/lzip") "-9"))
  87. (compressor "xz" ".xz"
  88. #~(append (list #+(file-append xz "/bin/xz")
  89. "-e")
  90. (%xz-parallel-args)))
  91. (compressor "bzip2" ".bz2"
  92. #~(list #+(file-append bzip2 "/bin/bzip2") "-9"))
  93. (compressor "zstd" ".zst"
  94. ;; The default level 3 compresses better than gzip in a
  95. ;; fraction of the time, while the highest level 19
  96. ;; (de)compresses more slowly and worse than xz.
  97. #~(list #+(file-append zstd "/bin/zstd") "-3"))
  98. (compressor "none" "" #f)))
  99. ;; This one is only for use in this module, so don't put it in %compressors.
  100. (define bootstrap-xz
  101. (compressor "bootstrap-xz" ".xz"
  102. #~(append (list #+(file-append %bootstrap-coreutils&co "/bin/xz")
  103. "-e")
  104. (%xz-parallel-args))))
  105. (define (lookup-compressor name)
  106. "Return the compressor object called NAME. Error out if it could not be
  107. found."
  108. (or (find (match-lambda
  109. (($ <compressor> name*)
  110. (string=? name* name)))
  111. %compressors)
  112. (leave (G_ "~a: compressor not found~%") name)))
  113. (define not-config?
  114. ;; Select (guix …) and (gnu …) modules, except (guix config).
  115. (match-lambda
  116. (('guix 'config) #f)
  117. (('guix _ ...) #t)
  118. (('gnu _ ...) #t)
  119. (_ #f)))
  120. (define gcrypt-sqlite3&co
  121. ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
  122. (append-map (lambda (package)
  123. (cons package
  124. (match (package-transitive-propagated-inputs package)
  125. (((labels packages) ...)
  126. packages))))
  127. (list guile-gcrypt guile-sqlite3)))
  128. (define (store-database items)
  129. "Return a directory containing a store database where all of ITEMS and their
  130. dependencies are registered."
  131. (define schema
  132. (local-file (search-path %load-path
  133. "guix/store/schema.sql")))
  134. (define labels
  135. (map (lambda (n)
  136. (string-append "closure" (number->string n)))
  137. (iota (length items))))
  138. (define build
  139. (with-extensions gcrypt-sqlite3&co
  140. (with-imported-modules `(((guix config) => ,(make-config.scm))
  141. ,@(source-module-closure
  142. '((guix build store-copy)
  143. (guix store database))
  144. #:select? not-config?))
  145. #~(begin
  146. (use-modules (guix store database)
  147. (guix build store-copy)
  148. (srfi srfi-1))
  149. (define (read-closure closure)
  150. (call-with-input-file closure read-reference-graph))
  151. (define db-file
  152. (store-database-file #:state-directory #$output))
  153. ;; Make sure non-ASCII file names are properly handled.
  154. (setenv "GUIX_LOCPATH"
  155. #+(file-append glibc-utf8-locales "/lib/locale"))
  156. (setlocale LC_ALL "en_US.utf8")
  157. (sql-schema #$schema)
  158. (let ((items (append-map read-closure '#$labels)))
  159. (with-database db-file db
  160. (register-items db items
  161. #:registration-time %epoch)))))))
  162. (computed-file "store-database" build
  163. #:options `(#:references-graphs ,(zip labels items))))
  164. (define* (self-contained-tarball name profile
  165. #:key target
  166. (profile-name "guix-profile")
  167. deduplicate?
  168. entry-point
  169. (compressor (first %compressors))
  170. localstatedir?
  171. (symlinks '())
  172. (archiver tar))
  173. "Return a self-contained tarball containing a store initialized with the
  174. closure of PROFILE, a derivation. The tarball contains /gnu/store; if
  175. LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db
  176. with a properly initialized store database.
  177. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
  178. added to the pack."
  179. (define database
  180. (and localstatedir?
  181. (file-append (store-database (list profile))
  182. "/db/db.sqlite")))
  183. (define set-utf8-locale
  184. ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'.
  185. (and (or (not (profile? profile))
  186. (profile-locales? profile))
  187. #~(begin
  188. (setenv "GUIX_LOCPATH"
  189. #+(file-append glibc-utf8-locales "/lib/locale"))
  190. (setlocale LC_ALL "en_US.utf8"))))
  191. (define (import-module? module)
  192. ;; Since we don't use deduplication support in 'populate-store', don't
  193. ;; import (guix store deduplication) and its dependencies, which includes
  194. ;; Guile-Gcrypt. That way we can run tests with '--bootstrap'.
  195. (and (not-config? module)
  196. (not (equal? '(guix store deduplication) module))))
  197. (define build
  198. (with-imported-modules (source-module-closure
  199. `((guix build utils)
  200. (guix build union)
  201. (gnu build install))
  202. #:select? import-module?)
  203. #~(begin
  204. (use-modules (guix build utils)
  205. ((guix build union) #:select (relative-file-name))
  206. (gnu build install)
  207. (srfi srfi-1)
  208. (srfi srfi-26)
  209. (ice-9 match))
  210. (define %root "root")
  211. (define symlink->directives
  212. ;; Return "populate directives" to make the given symlink and its
  213. ;; parent directories.
  214. (match-lambda
  215. ((source '-> target)
  216. (let ((target (string-append #$profile "/" target))
  217. (parent (dirname source)))
  218. ;; Never add a 'directory' directive for "/" so as to
  219. ;; preserve its ownnership when extracting the archive (see
  220. ;; below), and also because this would lead to adding the
  221. ;; same entries twice in the tarball.
  222. `(,@(if (string=? parent "/")
  223. '()
  224. `((directory ,parent)))
  225. (,source
  226. -> ,(relative-file-name parent target)))))))
  227. (define directives
  228. ;; Fully-qualified symlinks.
  229. (append-map symlink->directives '#$symlinks))
  230. ;; The --sort option was added to GNU tar in version 1.28, released
  231. ;; 2014-07-28. For testing, we use the bootstrap tar, which is
  232. ;; older and doesn't support it.
  233. (define tar-supports-sort?
  234. (zero? (system* (string-append #+archiver "/bin/tar")
  235. "cf" "/dev/null" "--files-from=/dev/null"
  236. "--sort=name")))
  237. ;; Make sure non-ASCII file names are properly handled.
  238. #+set-utf8-locale
  239. ;; Add 'tar' to the search path.
  240. (setenv "PATH" #+(file-append archiver "/bin"))
  241. ;; Note: there is not much to gain here with deduplication and there
  242. ;; is the overhead of the '.links' directory, so turn it off.
  243. ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
  244. ;; with hard links:
  245. ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
  246. (populate-single-profile-directory %root
  247. #:profile #$profile
  248. #:profile-name #$profile-name
  249. #:closure "profile"
  250. #:database #+database)
  251. ;; Create SYMLINKS.
  252. (for-each (cut evaluate-populate-directive <> %root)
  253. directives)
  254. ;; Create the tarball. Use GNU format so there's no file name
  255. ;; length limitation.
  256. (with-directory-excursion %root
  257. (exit
  258. (zero? (apply system* "tar"
  259. #+@(if (compressor-command compressor)
  260. #~("-I"
  261. (string-join
  262. #+(compressor-command compressor)))
  263. #~())
  264. "--format=gnu"
  265. ;; Avoid non-determinism in the archive. Use
  266. ;; mtime = 1, not zero, because that is what the
  267. ;; daemon does for files in the store (see the
  268. ;; 'mtimeStore' constant in local-store.cc.)
  269. (if tar-supports-sort? "--sort=name" "--mtime=@1")
  270. "--mtime=@1" ;for files in /var/guix
  271. "--owner=root:0"
  272. "--group=root:0"
  273. "--check-links"
  274. "-cvf" #$output
  275. ;; Avoid adding / and /var to the tarball, so
  276. ;; that the ownership and permissions of those
  277. ;; directories will not be overwritten when
  278. ;; extracting the archive. Do not include /root
  279. ;; because the root account might have a
  280. ;; different home directory.
  281. #$@(if localstatedir?
  282. '("./var/guix")
  283. '())
  284. (string-append "." (%store-directory))
  285. (delete-duplicates
  286. (filter-map (match-lambda
  287. (('directory directory)
  288. (string-append "." directory))
  289. ((source '-> _)
  290. (string-append "." source))
  291. (_ #f))
  292. directives)))))))))
  293. (when entry-point
  294. (warning (G_ "entry point not supported in the '~a' format~%")
  295. 'tarball))
  296. (gexp->derivation (string-append name ".tar"
  297. (compressor-extension compressor))
  298. build
  299. #:target target
  300. #:references-graphs `(("profile" ,profile))))
  301. (define (singularity-environment-file profile)
  302. "Return a shell script that defines the environment variables corresponding
  303. to the search paths of PROFILE."
  304. (define build
  305. (with-extensions (list guile-gcrypt)
  306. (with-imported-modules `(((guix config) => ,(make-config.scm))
  307. ,@(source-module-closure
  308. `((guix profiles)
  309. (guix search-paths))
  310. #:select? not-config?))
  311. #~(begin
  312. (use-modules (guix profiles) (guix search-paths)
  313. (ice-9 match))
  314. (call-with-output-file #$output
  315. (lambda (port)
  316. (for-each (match-lambda
  317. ((spec . value)
  318. (format port "~a=~a~%export ~a~%"
  319. (search-path-specification-variable spec)
  320. value
  321. (search-path-specification-variable spec))))
  322. (profile-search-paths #$profile))))))))
  323. (computed-file "singularity-environment.sh" build))
  324. (define* (squashfs-image name profile
  325. #:key target
  326. (profile-name "guix-profile")
  327. (compressor (first %compressors))
  328. entry-point
  329. localstatedir?
  330. (symlinks '())
  331. (archiver squashfs-tools))
  332. "Return a squashfs image containing a store initialized with the closure of
  333. PROFILE, a derivation. The image contains a subset of /gnu/store, empty mount
  334. points for virtual file systems (like procfs), and optional symlinks.
  335. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
  336. added to the pack."
  337. (define database
  338. (and localstatedir?
  339. (file-append (store-database (list profile))
  340. "/db/db.sqlite")))
  341. (define environment
  342. (singularity-environment-file profile))
  343. (define symlinks*
  344. ;; Singularity requires /bin (specifically /bin/sh), so ensure that
  345. ;; symlink is created.
  346. (if (find (match-lambda
  347. (("/bin" . _) #t)
  348. (_ #f))
  349. symlinks)
  350. symlinks
  351. `(("/bin" -> "bin") ,@symlinks)))
  352. (define build
  353. (with-extensions (list guile-gcrypt)
  354. (with-imported-modules (source-module-closure
  355. '((guix build utils)
  356. (guix build store-copy)
  357. (guix build union)
  358. (gnu build install))
  359. #:select? not-config?)
  360. #~(begin
  361. (use-modules (guix build utils)
  362. (guix build store-copy)
  363. ((guix build union) #:select (relative-file-name))
  364. (gnu build install)
  365. (srfi srfi-1)
  366. (srfi srfi-26)
  367. (ice-9 match))
  368. (define database #+database)
  369. (define entry-point #$entry-point)
  370. (define (mksquashfs args)
  371. (apply invoke "mksquashfs"
  372. `(,@args
  373. ;; Do not create a "recovery file" when appending to the
  374. ;; file system since it's useless in this case.
  375. "-no-recovery"
  376. ;; Do not attempt to store extended attributes.
  377. ;; See <https://bugs.gnu.org/40043>.
  378. "-no-xattrs"
  379. ;; Set file times and the file system creation time to
  380. ;; one second after the Epoch.
  381. "-all-time" "1" "-mkfs-time" "1"
  382. ;; Reset all UIDs and GIDs.
  383. "-force-uid" "0" "-force-gid" "0")))
  384. (setenv "PATH" #+(file-append archiver "/bin"))
  385. ;; We need an empty file in order to have a valid file argument when
  386. ;; we reparent the root file system. Read on for why that's
  387. ;; necessary.
  388. (with-output-to-file ".empty" (lambda () (display "")))
  389. ;; Create the squashfs image in several steps.
  390. ;; Add all store items. Unfortunately mksquashfs throws away all
  391. ;; ancestor directories and only keeps the basename. We fix this
  392. ;; in the following invocations of mksquashfs.
  393. (mksquashfs `(,@(map store-info-item
  394. (call-with-input-file "profile"
  395. read-reference-graph))
  396. #$environment
  397. ,#$output
  398. ;; Do not perform duplicate checking because we
  399. ;; don't have any dupes.
  400. "-no-duplicates"
  401. "-comp"
  402. ,#+(compressor-name compressor)))
  403. ;; Here we reparent the store items. For each sub-directory of
  404. ;; the store prefix we need one invocation of "mksquashfs".
  405. (for-each (lambda (dir)
  406. (mksquashfs `(".empty"
  407. ,#$output
  408. "-root-becomes" ,dir)))
  409. (reverse (string-tokenize (%store-directory)
  410. (char-set-complement (char-set #\/)))))
  411. ;; Add symlinks and mount points.
  412. (mksquashfs
  413. `(".empty"
  414. ,#$output
  415. ;; Create SYMLINKS via pseudo file definitions.
  416. ,@(append-map
  417. (match-lambda
  418. ((source '-> target)
  419. ;; Create relative symlinks to work around a bug in
  420. ;; Singularity 2.x:
  421. ;; https://bugs.gnu.org/34913
  422. ;; https://github.com/sylabs/singularity/issues/1487
  423. (let ((target (string-append #$profile "/" target)))
  424. (list "-p"
  425. (string-join
  426. ;; name s mode uid gid symlink
  427. (list source
  428. "s" "777" "0" "0"
  429. (relative-file-name (dirname source)
  430. target)))))))
  431. '#$symlinks*)
  432. "-p" "/.singularity.d d 555 0 0"
  433. ;; Create the environment file.
  434. "-p" "/.singularity.d/env d 555 0 0"
  435. "-p" ,(string-append
  436. "/.singularity.d/env/90-environment.sh s 777 0 0 "
  437. (relative-file-name "/.singularity.d/env"
  438. #$environment))
  439. ;; Create /.singularity.d/actions, and optionally the 'run'
  440. ;; script, used by 'singularity run'.
  441. "-p" "/.singularity.d/actions d 555 0 0"
  442. ,@(if entry-point
  443. `( ;; This one if for Singularity 2.x.
  444. "-p"
  445. ,(string-append
  446. "/.singularity.d/actions/run s 777 0 0 "
  447. (relative-file-name "/.singularity.d/actions"
  448. (string-append #$profile "/"
  449. entry-point)))
  450. ;; This one is for Singularity 3.x.
  451. "-p"
  452. ,(string-append
  453. "/.singularity.d/runscript s 777 0 0 "
  454. (relative-file-name "/.singularity.d"
  455. (string-append #$profile "/"
  456. entry-point))))
  457. '())
  458. ;; Create empty mount points.
  459. "-p" "/proc d 555 0 0"
  460. "-p" "/sys d 555 0 0"
  461. "-p" "/dev d 555 0 0"
  462. "-p" "/home d 555 0 0"))
  463. (when database
  464. ;; Initialize /var/guix.
  465. (install-database-and-gc-roots "var-etc" database #$profile)
  466. (mksquashfs `("var-etc" ,#$output)))))))
  467. (gexp->derivation (string-append name
  468. (compressor-extension compressor)
  469. ".squashfs")
  470. build
  471. #:target target
  472. #:references-graphs `(("profile" ,profile))))
  473. (define* (docker-image name profile
  474. #:key target
  475. (profile-name "guix-profile")
  476. (compressor (first %compressors))
  477. entry-point
  478. localstatedir?
  479. (symlinks '())
  480. (archiver tar))
  481. "Return a derivation to construct a Docker image of PROFILE. The
  482. image is a tarball conforming to the Docker Image Specification, compressed
  483. with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it
  484. must a be a GNU triplet and it is used to derive the architecture metadata in
  485. the image."
  486. (define database
  487. (and localstatedir?
  488. (file-append (store-database (list profile))
  489. "/db/db.sqlite")))
  490. (define defmod 'define-module) ;trick Geiser
  491. (define build
  492. ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
  493. (with-extensions (list guile-json-3 guile-gcrypt)
  494. (with-imported-modules `(((guix config) => ,(make-config.scm))
  495. ,@(source-module-closure
  496. `((guix docker)
  497. (guix build store-copy)
  498. (guix build utils) ;for %xz-parallel-args
  499. (guix profiles)
  500. (guix search-paths))
  501. #:select? not-config?))
  502. #~(begin
  503. (use-modules (guix docker) (guix build store-copy)
  504. (guix build utils)
  505. (guix profiles) (guix search-paths)
  506. (srfi srfi-1) (srfi srfi-19)
  507. (ice-9 match))
  508. (define environment
  509. (map (match-lambda
  510. ((spec . value)
  511. (cons (search-path-specification-variable spec)
  512. value)))
  513. (profile-search-paths #$profile)))
  514. (define symlink->directives
  515. ;; Return "populate directives" to make the given symlink and its
  516. ;; parent directories.
  517. (match-lambda
  518. ((source '-> target)
  519. (let ((target (string-append #$profile "/" target))
  520. (parent (dirname source)))
  521. `((directory ,parent)
  522. (,source -> ,target))))))
  523. (define directives
  524. ;; Create a /tmp directory, as some programs expect it, and
  525. ;; create SYMLINKS.
  526. `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
  527. ,@(append-map symlink->directives '#$symlinks)))
  528. (define tag
  529. ;; Compute a meaningful "repository" name, which will show up in
  530. ;; the output of "docker images".
  531. (let ((manifest (profile-manifest #$profile)))
  532. (let loop ((names (map manifest-entry-name
  533. (manifest-entries manifest))))
  534. (define str (string-join names "-"))
  535. (if (< (string-length str) 40)
  536. str
  537. (match names
  538. ((_) str)
  539. ((names ... _) (loop names))))))) ;drop one entry
  540. (setenv "PATH" #+(file-append archiver "/bin"))
  541. (build-docker-image #$output
  542. (map store-info-item
  543. (call-with-input-file "profile"
  544. read-reference-graph))
  545. #$profile
  546. #:repository tag
  547. #:database #+database
  548. #:system (or #$target (utsname:machine (uname)))
  549. #:environment environment
  550. #:entry-point
  551. #$(and entry-point
  552. #~(list (string-append #$profile "/"
  553. #$entry-point)))
  554. #:extra-files directives
  555. #:compressor #+(compressor-command compressor)
  556. #:creation-time (make-time time-utc 0 1))))))
  557. (gexp->derivation (string-append name ".tar"
  558. (compressor-extension compressor))
  559. build
  560. #:target target
  561. #:references-graphs `(("profile" ,profile))))
  562. ;;;
  563. ;;; Compiling C programs.
  564. ;;;
  565. ;; A C compiler. That lowers to a single program that can be passed typical C
  566. ;; compiler flags, and it makes sure the whole toolchain is available.
  567. (define-record-type <c-compiler>
  568. (%c-compiler toolchain guile)
  569. c-compiler?
  570. (toolchain c-compiler-toolchain)
  571. (guile c-compiler-guile))
  572. (define* (c-compiler #:optional inputs
  573. #:key (guile (default-guile)))
  574. (%c-compiler inputs guile))
  575. (define (bootstrap-c-compiler)
  576. "Return the C compiler that uses the bootstrap toolchain. This is used only
  577. by '--bootstrap', for testing purposes."
  578. (define bootstrap-toolchain
  579. (list (first (assoc-ref (%bootstrap-inputs) "gcc"))
  580. (first (assoc-ref (%bootstrap-inputs) "binutils"))
  581. (first (assoc-ref (%bootstrap-inputs) "libc"))))
  582. (c-compiler bootstrap-toolchain
  583. #:guile %bootstrap-guile))
  584. (define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target)
  585. "Lower COMPILER to a single script that does the right thing."
  586. (define toolchain
  587. (or (c-compiler-toolchain compiler)
  588. (list (first (assoc-ref (standard-packages) "gcc"))
  589. (first (assoc-ref (standard-packages) "ld-wrapper"))
  590. (first (assoc-ref (standard-packages) "binutils"))
  591. (first (assoc-ref (standard-packages) "libc"))
  592. (gexp-input (first (assoc-ref (standard-packages) "libc"))
  593. "static"))))
  594. (define inputs
  595. (match (append-map package-propagated-inputs
  596. (filter package? toolchain))
  597. (((labels things . _) ...)
  598. (append toolchain things))))
  599. (define search-paths
  600. (cons $PATH
  601. (append-map package-native-search-paths
  602. (filter package? inputs))))
  603. (define run
  604. (with-imported-modules (source-module-closure
  605. '((guix build utils)
  606. (guix search-paths)))
  607. #~(begin
  608. (use-modules (guix build utils) (guix search-paths)
  609. (ice-9 match))
  610. (define (output-file args)
  611. (let loop ((args args))
  612. (match args
  613. (() "a.out")
  614. (("-o" file _ ...) file)
  615. ((head rest ...) (loop rest)))))
  616. (set-search-paths (map sexp->search-path-specification
  617. '#$(map search-path-specification->sexp
  618. search-paths))
  619. '#$inputs)
  620. (let ((output (output-file (command-line))))
  621. (apply invoke "gcc" (cdr (command-line)))
  622. (invoke "strip" output)))))
  623. (when target
  624. ;; TODO: Yep, we'll have to do it someday!
  625. (leave (G_ "cross-compilation not implemented here;
  626. please email '~a'~%")
  627. (@ (guix config) %guix-bug-report-address)))
  628. (gexp->script "c-compiler" run
  629. #:guile (c-compiler-guile compiler)))
  630. ;;;
  631. ;;; Wrapped package.
  632. ;;;
  633. (define* (wrapped-package package
  634. #:optional
  635. (output* "out")
  636. (compiler (c-compiler))
  637. #:key proot?)
  638. "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are
  639. relocatable. When PROOT? is true, include PRoot in the result and use it as a
  640. last resort for relocation."
  641. (define runner
  642. (local-file (search-auxiliary-file "run-in-namespace.c")))
  643. (define audit-source
  644. (local-file (search-auxiliary-file "pack-audit.c")))
  645. (define (proot)
  646. (specification->package "proot-static"))
  647. (define (fakechroot-library)
  648. (computed-file "libfakechroot.so"
  649. #~(copy-file #$(file-append
  650. (specification->package "fakechroot")
  651. "/lib/fakechroot/libfakechroot.so")
  652. #$output)))
  653. (define (audit-module)
  654. ;; Return an ld.so audit module for use by the 'fakechroot' execution
  655. ;; engine that translates file names of all the files ld.so loads.
  656. (computed-file "pack-audit.so"
  657. (with-imported-modules '((guix build utils))
  658. #~(begin
  659. (use-modules (guix build utils))
  660. (copy-file #$audit-source "audit.c")
  661. (substitute* "audit.c"
  662. (("@STORE_DIRECTORY@")
  663. (%store-directory)))
  664. (invoke #$compiler "-std=gnu99"
  665. "-shared" "-fPIC" "-Os" "-g0"
  666. "-Wall" "audit.c" "-o" #$output)))))
  667. (define build
  668. (with-imported-modules (source-module-closure
  669. '((guix build utils)
  670. (guix build union)
  671. (guix build gremlin)
  672. (guix elf)))
  673. #~(begin
  674. (use-modules (guix build utils)
  675. ((guix build union) #:select (symlink-relative))
  676. (guix elf)
  677. (guix build gremlin)
  678. (ice-9 binary-ports)
  679. (ice-9 ftw)
  680. (ice-9 match)
  681. (ice-9 receive)
  682. (srfi srfi-1)
  683. (rnrs bytevectors))
  684. (define input
  685. ;; The OUTPUT* output of PACKAGE.
  686. (ungexp package output*))
  687. (define target
  688. ;; The output we are producing.
  689. (ungexp output output*))
  690. (define (strip-store-prefix file)
  691. ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
  692. ;; "/bin/foo".
  693. (let* ((len (string-length (%store-directory)))
  694. (base (string-drop file (+ 1 len))))
  695. (match (string-index base #\/)
  696. (#f base)
  697. (index (string-drop base index)))))
  698. (define (elf-interpreter elf)
  699. ;; Return the interpreter of ELF as a string, or #f if ELF has no
  700. ;; interpreter segment.
  701. (match (find (lambda (segment)
  702. (= (elf-segment-type segment) PT_INTERP))
  703. (elf-segments elf))
  704. (#f #f) ;maybe a .so
  705. (segment
  706. (let ((bv (make-bytevector (- (elf-segment-memsz segment) 1))))
  707. (bytevector-copy! (elf-bytes elf)
  708. (elf-segment-offset segment)
  709. bv 0 (bytevector-length bv))
  710. (utf8->string bv)))))
  711. (define (runpath file)
  712. ;; Return the RUNPATH of FILE as a list of directories.
  713. (let* ((bv (call-with-input-file file get-bytevector-all))
  714. (elf (parse-elf bv))
  715. (dyninfo (elf-dynamic-info elf)))
  716. (or (and=> dyninfo elf-dynamic-info-runpath)
  717. '())))
  718. (define (elf-loader-compile-flags program)
  719. ;; Return the cpp flags defining macros for the ld.so/fakechroot
  720. ;; wrapper of PROGRAM.
  721. ;; TODO: Handle scripts by wrapping their interpreter.
  722. (if (elf-file? program)
  723. (let* ((bv (call-with-input-file program
  724. get-bytevector-all))
  725. (elf (parse-elf bv))
  726. (interp (elf-interpreter elf))
  727. (gconv (and interp
  728. (string-append (dirname interp)
  729. "/gconv"))))
  730. (if interp
  731. (list (string-append "-DPROGRAM_INTERPRETER=\""
  732. interp "\"")
  733. (string-append "-DFAKECHROOT_LIBRARY=\""
  734. #$(fakechroot-library) "\"")
  735. (string-append "-DLOADER_AUDIT_MODULE=\""
  736. #$(audit-module) "\"")
  737. ;; XXX: Normally (runpath #$(audit-module)) is
  738. ;; enough. However, to work around
  739. ;; <https://sourceware.org/bugzilla/show_bug.cgi?id=26634>
  740. ;; (glibc <= 2.32), pass the whole search path of
  741. ;; PROGRAM, which presumably is a superset of that
  742. ;; of the audit module.
  743. (string-append "-DLOADER_AUDIT_RUNPATH={ "
  744. (string-join
  745. (map object->string
  746. (runpath program))
  747. ", " 'suffix)
  748. "NULL }")
  749. (if gconv
  750. (string-append "-DGCONV_DIRECTORY=\""
  751. gconv "\"")
  752. "-UGCONV_DIRECTORY"))
  753. '()))
  754. '()))
  755. (define (build-wrapper program)
  756. ;; Build a user-namespace wrapper for PROGRAM.
  757. (format #t "building wrapper for '~a'...~%" program)
  758. (copy-file #$runner "run.c")
  759. (substitute* "run.c"
  760. (("@WRAPPED_PROGRAM@") program)
  761. (("@STORE_DIRECTORY@") (%store-directory)))
  762. (let* ((base (strip-store-prefix program))
  763. (result (string-append target base))
  764. (proot #$(and proot?
  765. #~(string-drop
  766. #$(file-append (proot) "/bin/proot")
  767. (+ (string-length (%store-directory))
  768. 1)))))
  769. (mkdir-p (dirname result))
  770. (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
  771. "run.c" "-o" result
  772. (string-append "-DWRAPPER_PROGRAM=\""
  773. (canonicalize-path (dirname result)) "/"
  774. (basename result) "\"")
  775. (append (if proot
  776. (list (string-append "-DPROOT_PROGRAM=\""
  777. proot "\""))
  778. '())
  779. (elf-loader-compile-flags program)))
  780. (delete-file "run.c")))
  781. (setvbuf (current-output-port) 'line)
  782. ;; Link the top-level files of PACKAGE so that search paths are
  783. ;; properly defined in PROFILE/etc/profile.
  784. (mkdir target)
  785. (for-each (lambda (file)
  786. (unless (member file '("." ".." "bin" "sbin" "libexec"))
  787. (symlink-relative (string-append input "/" file)
  788. (string-append target "/" file))))
  789. (scandir input))
  790. (receive (executables others)
  791. (partition executable-file?
  792. ;; Note: Trailing slash in case these are symlinks.
  793. (append (find-files (string-append input "/bin/"))
  794. (find-files (string-append input "/sbin/"))
  795. (find-files (string-append input "/libexec/"))))
  796. ;; Wrap only executables, since the wrapper will eventually need
  797. ;; to execve them. E.g. git's "libexec" directory contains many
  798. ;; shell scripts that are source'd from elsewhere, which fails if
  799. ;; they are wrapped.
  800. (for-each build-wrapper executables)
  801. ;; Link any other non-executable files
  802. (for-each (lambda (old)
  803. (let ((new (string-append target (strip-store-prefix old))))
  804. (mkdir-p (dirname new))
  805. (symlink-relative old new)))
  806. others)))))
  807. (computed-file (string-append
  808. (cond ((package? package)
  809. (package-full-name package "-"))
  810. ((inferior-package? package)
  811. (string-append (inferior-package-name package)
  812. "-"
  813. (inferior-package-version package)))
  814. (else "wrapper"))
  815. "R")
  816. build))
  817. (define (wrapped-manifest-entry entry . args)
  818. (manifest-entry
  819. (inherit entry)
  820. (item (apply wrapped-package
  821. (manifest-entry-item entry)
  822. (manifest-entry-output entry)
  823. args))
  824. (dependencies (map (lambda (entry)
  825. (apply wrapped-manifest-entry entry args))
  826. (manifest-entry-dependencies entry)))))
  827. ;;;
  828. ;;; Command-line options.
  829. ;;;
  830. (define %default-options
  831. ;; Alist of default option values.
  832. `((format . tarball)
  833. (profile-name . "guix-profile")
  834. (system . ,(%current-system))
  835. (substitutes? . #t)
  836. (offload? . #t)
  837. (graft? . #t)
  838. (print-build-trace? . #t)
  839. (print-extended-build-trace? . #t)
  840. (multiplexed-build-output? . #t)
  841. (debug . 0)
  842. (verbosity . 1)
  843. (symlinks . ())
  844. (compressor . ,(first %compressors))))
  845. (define %formats
  846. ;; Supported pack formats.
  847. `((tarball . ,self-contained-tarball)
  848. (squashfs . ,squashfs-image)
  849. (docker . ,docker-image)))
  850. (define (show-formats)
  851. ;; Print the supported pack formats.
  852. (display (G_ "The supported formats for 'guix pack' are:"))
  853. (newline)
  854. (display (G_ "
  855. tarball Self-contained tarball, ready to run on another machine"))
  856. (display (G_ "
  857. squashfs Squashfs image suitable for Singularity"))
  858. (display (G_ "
  859. docker Tarball ready for 'docker load'"))
  860. (newline))
  861. (define %options
  862. ;; Specifications of the command-line options.
  863. (cons* (option '(#\h "help") #f #f
  864. (lambda args
  865. (show-help)
  866. (exit 0)))
  867. (option '(#\V "version") #f #f
  868. (lambda args
  869. (show-version-and-exit "guix pack")))
  870. (option '(#\n "dry-run") #f #f
  871. (lambda (opt name arg result)
  872. (alist-cons 'dry-run? #t result)))
  873. (option '(#\d "derivation") #f #f
  874. (lambda (opt name arg result)
  875. (alist-cons 'derivation-only? #t result)))
  876. (option '(#\f "format") #t #f
  877. (lambda (opt name arg result)
  878. (alist-cons 'format (string->symbol arg) result)))
  879. (option '("list-formats") #f #f
  880. (lambda args
  881. (show-formats)
  882. (exit 0)))
  883. (option '(#\R "relocatable") #f #f
  884. (lambda (opt name arg result)
  885. (match (assq-ref result 'relocatable?)
  886. (#f
  887. (alist-cons 'relocatable? #t result))
  888. (_
  889. (alist-cons 'relocatable? 'proot
  890. (alist-delete 'relocatable? result))))))
  891. (option '(#\e "expression") #t #f
  892. (lambda (opt name arg result)
  893. (alist-cons 'expression arg result)))
  894. (option '(#\m "manifest") #t #f
  895. (lambda (opt name arg result)
  896. (alist-cons 'manifest arg result)))
  897. (option '(#\s "system") #t #f
  898. (lambda (opt name arg result)
  899. (alist-cons 'system arg
  900. (alist-delete 'system result eq?))))
  901. (option '("entry-point") #t #f
  902. (lambda (opt name arg result)
  903. (alist-cons 'entry-point arg result)))
  904. (option '("target") #t #f
  905. (lambda (opt name arg result)
  906. (alist-cons 'target arg
  907. (alist-delete 'target result eq?))))
  908. (option '(#\C "compression") #t #f
  909. (lambda (opt name arg result)
  910. (alist-cons 'compressor (lookup-compressor arg)
  911. result)))
  912. (option '(#\S "symlink") #t #f
  913. (lambda (opt name arg result)
  914. ;; Note: Using 'string-split' allows us to handle empty
  915. ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is
  916. ;; a symlink to the profile) correctly.
  917. (match (string-split arg (char-set #\=))
  918. ((source target)
  919. (let ((symlinks (assoc-ref result 'symlinks)))
  920. (alist-cons 'symlinks
  921. `((,source -> ,target) ,@symlinks)
  922. (alist-delete 'symlinks result eq?))))
  923. (x
  924. (leave (G_ "~a: invalid symlink specification~%")
  925. arg)))))
  926. (option '("save-provenance") #f #f
  927. (lambda (opt name arg result)
  928. (alist-cons 'save-provenance? #t result)))
  929. (option '("localstatedir") #f #f
  930. (lambda (opt name arg result)
  931. (alist-cons 'localstatedir? #t result)))
  932. (option '("profile-name") #t #f
  933. (lambda (opt name arg result)
  934. (match arg
  935. ((or "guix-profile" "current-guix")
  936. (alist-cons 'profile-name arg result))
  937. (_
  938. (leave (G_ "~a: unsupported profile name~%") arg)))))
  939. (option '(#\r "root") #t #f
  940. (lambda (opt name arg result)
  941. (alist-cons 'gc-root arg result)))
  942. (option '(#\v "verbosity") #t #f
  943. (lambda (opt name arg result)
  944. (let ((level (string->number* arg)))
  945. (alist-cons 'verbosity level
  946. (alist-delete 'verbosity result)))))
  947. (option '("bootstrap") #f #f
  948. (lambda (opt name arg result)
  949. (alist-cons 'bootstrap? #t result)))
  950. (append %transformation-options
  951. %standard-build-options)))
  952. (define (show-help)
  953. (display (G_ "Usage: guix pack [OPTION]... PACKAGE...
  954. Create a bundle of PACKAGE.\n"))
  955. (show-build-options-help)
  956. (newline)
  957. (show-transformation-options-help)
  958. (newline)
  959. (display (G_ "
  960. -f, --format=FORMAT build a pack in the given FORMAT"))
  961. (display (G_ "
  962. --list-formats list the formats available"))
  963. (display (G_ "
  964. -R, --relocatable produce relocatable executables"))
  965. (display (G_ "
  966. -e, --expression=EXPR consider the package EXPR evaluates to"))
  967. (display (G_ "
  968. -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
  969. (display (G_ "
  970. --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
  971. (display (G_ "
  972. -C, --compression=TOOL compress using TOOL--e.g., \"lzip\""))
  973. (display (G_ "
  974. -S, --symlink=SPEC create symlinks to the profile according to SPEC"))
  975. (display (G_ "
  976. -m, --manifest=FILE create a pack with the manifest from FILE"))
  977. (display (G_ "
  978. --entry-point=PROGRAM
  979. use PROGRAM as the entry point of the pack"))
  980. (display (G_ "
  981. --save-provenance save provenance information"))
  982. (display (G_ "
  983. --localstatedir include /var/guix in the resulting pack"))
  984. (display (G_ "
  985. --profile-name=NAME
  986. populate /var/guix/profiles/.../NAME"))
  987. (display (G_ "
  988. -r, --root=FILE make FILE a symlink to the result, and register it
  989. as a garbage collector root"))
  990. (display (G_ "
  991. -d, --derivation return the derivation of the pack"))
  992. (display (G_ "
  993. -v, --verbosity=LEVEL use the given verbosity LEVEL"))
  994. (display (G_ "
  995. --bootstrap use the bootstrap binaries to build the pack"))
  996. (newline)
  997. (display (G_ "
  998. -h, --help display this help and exit"))
  999. (display (G_ "
  1000. -V, --version display version information and exit"))
  1001. (newline)
  1002. (show-bug-report-information))
  1003. ;;;
  1004. ;;; Entry point.
  1005. ;;;
  1006. (define-command (guix-pack . args)
  1007. (category development)
  1008. (synopsis "create application bundles")
  1009. (define opts
  1010. (parse-command-line args %options (list %default-options)))
  1011. (define maybe-package-argument
  1012. ;; Given an option pair, return a package, a package/output tuple, or #f.
  1013. (match-lambda
  1014. (('argument . spec)
  1015. (call-with-values
  1016. (lambda ()
  1017. (specification->package+output spec))
  1018. list))
  1019. (('expression . exp)
  1020. (read/eval-package-expression exp))
  1021. (x #f)))
  1022. (define (manifest-from-args store opts)
  1023. (let* ((transform (options->transformation opts))
  1024. (packages (map (match-lambda
  1025. (((? package? package) output)
  1026. (list (transform package) output))
  1027. ((? package? package)
  1028. (list (transform package) "out")))
  1029. (reverse
  1030. (filter-map maybe-package-argument opts))))
  1031. (manifests (filter-map (match-lambda
  1032. (('manifest . file) file)
  1033. (_ #f))
  1034. opts)))
  1035. (define with-provenance
  1036. (if (assoc-ref opts 'save-provenance?)
  1037. (lambda (manifest)
  1038. (map-manifest-entries
  1039. (lambda (entry)
  1040. (let ((entry (manifest-entry-with-provenance entry)))
  1041. (unless (assq 'provenance (manifest-entry-properties entry))
  1042. (warning (G_ "could not determine provenance of package ~a~%")
  1043. (manifest-entry-name entry)))
  1044. entry))
  1045. manifest))
  1046. identity))
  1047. (with-provenance
  1048. (cond
  1049. ((and (not (null? manifests)) (not (null? packages)))
  1050. (leave (G_ "both a manifest and a package list were given~%")))
  1051. ((not (null? manifests))
  1052. (concatenate-manifests
  1053. (map (lambda (file)
  1054. (let ((user-module (make-user-module
  1055. '((guix profiles) (gnu)))))
  1056. (load* file user-module)))
  1057. manifests)))
  1058. (else
  1059. (packages->manifest packages))))))
  1060. (with-error-handling
  1061. (with-store store
  1062. (with-status-verbosity (assoc-ref opts 'verbosity)
  1063. ;; Set the build options before we do anything else.
  1064. (set-build-options-from-command-line store opts)
  1065. (with-build-handler (build-notifier #:dry-run?
  1066. (assoc-ref opts 'dry-run?)
  1067. #:verbosity
  1068. (assoc-ref opts 'verbosity)
  1069. #:use-substitutes?
  1070. (assoc-ref opts 'substitutes?))
  1071. (parameterize ((%graft? (assoc-ref opts 'graft?))
  1072. (%guile-for-build (package-derivation
  1073. store
  1074. (if (assoc-ref opts 'bootstrap?)
  1075. %bootstrap-guile
  1076. (default-guile))
  1077. (assoc-ref opts 'system)
  1078. #:graft? (assoc-ref opts 'graft?))))
  1079. (let* ((derivation? (assoc-ref opts 'derivation-only?))
  1080. (relocatable? (assoc-ref opts 'relocatable?))
  1081. (proot? (eq? relocatable? 'proot))
  1082. (manifest (let ((manifest (manifest-from-args store opts)))
  1083. ;; Note: We cannot honor '--bootstrap' here because
  1084. ;; 'glibc-bootstrap' lacks 'libc.a'.
  1085. (if relocatable?
  1086. (map-manifest-entries
  1087. (cut wrapped-manifest-entry <> #:proot? proot?)
  1088. manifest)
  1089. manifest)))
  1090. (pack-format (assoc-ref opts 'format))
  1091. (name (string-append (symbol->string pack-format)
  1092. "-pack"))
  1093. (target (assoc-ref opts 'target))
  1094. (bootstrap? (assoc-ref opts 'bootstrap?))
  1095. (compressor (if bootstrap?
  1096. bootstrap-xz
  1097. (assoc-ref opts 'compressor)))
  1098. (archiver (if (equal? pack-format 'squashfs)
  1099. squashfs-tools
  1100. (if bootstrap?
  1101. %bootstrap-coreutils&co
  1102. tar)))
  1103. (symlinks (assoc-ref opts 'symlinks))
  1104. (build-image (match (assq-ref %formats pack-format)
  1105. ((? procedure? proc) proc)
  1106. (#f
  1107. (leave (G_ "~a: unknown pack format~%")
  1108. pack-format))))
  1109. (localstatedir? (assoc-ref opts 'localstatedir?))
  1110. (entry-point (assoc-ref opts 'entry-point))
  1111. (profile-name (assoc-ref opts 'profile-name))
  1112. (gc-root (assoc-ref opts 'gc-root))
  1113. (profile (profile
  1114. (content manifest)
  1115. ;; Always produce relative symlinks for
  1116. ;; Singularity (see
  1117. ;; <https://bugs.gnu.org/34913>).
  1118. (relative-symlinks?
  1119. (or relocatable?
  1120. (eq? 'squashfs pack-format)))
  1121. (hooks (if bootstrap?
  1122. '()
  1123. %default-profile-hooks))
  1124. (locales? (not bootstrap?)))))
  1125. (define (lookup-package package)
  1126. (manifest-lookup manifest (manifest-pattern (name package))))
  1127. (when (null? (manifest-entries manifest))
  1128. (warning (G_ "no packages specified; building an empty pack~%")))
  1129. (when (and (eq? pack-format 'squashfs)
  1130. (not (any lookup-package '("bash" "bash-minimal"))))
  1131. (warning (G_ "Singularity requires you to provide a shell~%"))
  1132. (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \
  1133. to your package list.")))
  1134. (run-with-store store
  1135. (mlet* %store-monad ((drv (build-image name profile
  1136. #:target
  1137. target
  1138. #:compressor
  1139. compressor
  1140. #:symlinks
  1141. symlinks
  1142. #:localstatedir?
  1143. localstatedir?
  1144. #:entry-point
  1145. entry-point
  1146. #:profile-name
  1147. profile-name
  1148. #:archiver
  1149. archiver)))
  1150. (mbegin %store-monad
  1151. (mwhen derivation?
  1152. (return (format #t "~a~%"
  1153. (derivation-file-name drv))))
  1154. (munless derivation?
  1155. (built-derivations (list drv))
  1156. (mwhen gc-root
  1157. (register-root* (match (derivation->output-paths drv)
  1158. (((names . items) ...)
  1159. items))
  1160. gc-root))
  1161. (return (format #t "~a~%"
  1162. (derivation->output-path drv))))))
  1163. #:target target
  1164. #:system (assoc-ref opts 'system)))))))))