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