Commit | Line | Data |
---|---|---|
239c2266 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> | |
63102406 | 3 | ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> |
239c2266 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix scripts pack) | |
21 | #:use-module (guix scripts) | |
22 | #:use-module (guix ui) | |
23 | #:use-module (guix gexp) | |
24 | #:use-module (guix utils) | |
25 | #:use-module (guix store) | |
26 | #:use-module (guix grafts) | |
27 | #:use-module (guix monads) | |
b1edfbc3 | 28 | #:use-module (guix modules) |
239c2266 LC |
29 | #:use-module (guix packages) |
30 | #:use-module (guix profiles) | |
31 | #:use-module (guix derivations) | |
32 | #:use-module (guix scripts build) | |
33 | #:use-module (gnu packages) | |
34 | #:use-module (gnu packages compression) | |
35 | #:autoload (gnu packages base) (tar) | |
36 | #:autoload (gnu packages package-management) (guix) | |
b1edfbc3 | 37 | #:autoload (gnu packages gnupg) (libgcrypt) |
96afb480 | 38 | #:autoload (gnu packages guile) (guile2.0-json guile-json) |
239c2266 LC |
39 | #:use-module (srfi srfi-1) |
40 | #:use-module (srfi srfi-9) | |
41 | #:use-module (srfi srfi-37) | |
42 | #:use-module (ice-9 match) | |
43 | #:export (compressor? | |
44 | lookup-compressor | |
45 | self-contained-tarball | |
46 | guix-pack)) | |
47 | ||
48 | ;; Type of a compression tool. | |
49 | (define-record-type <compressor> | |
48b44430 | 50 | (compressor name extension command) |
239c2266 | 51 | compressor? |
48b44430 LC |
52 | (name compressor-name) ;string (e.g., "gzip") |
53 | (extension compressor-extension) ;string (e.g., "lz") | |
54 | (command compressor-command)) ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n")) | |
239c2266 LC |
55 | |
56 | (define %compressors | |
57 | ;; Available compression tools. | |
48b44430 LC |
58 | (list (compressor "gzip" "gz" |
59 | #~(#+(file-append gzip "/bin/gzip") "-9n")) | |
60 | (compressor "lzip" "lz" | |
61 | #~(#+(file-append lzip "/bin/lzip") "-9")) | |
62 | (compressor "xz" "xz" | |
63102406 | 63 | #~(#+(file-append xz "/bin/xz") "-e -T0")) |
48b44430 LC |
64 | (compressor "bzip2" "bz2" |
65 | #~(#+(file-append bzip2 "/bin/bzip2") "-9")))) | |
239c2266 LC |
66 | |
67 | (define (lookup-compressor name) | |
68 | "Return the compressor object called NAME. Error out if it could not be | |
69 | found." | |
70 | (or (find (match-lambda | |
71 | (($ <compressor> name*) | |
72 | (string=? name* name))) | |
73 | %compressors) | |
69daee23 | 74 | (leave (G_ "~a: compressor not found~%") name))) |
239c2266 LC |
75 | |
76 | (define* (self-contained-tarball name profile | |
5461115e LC |
77 | #:key target |
78 | deduplicate? | |
6b63c43e | 79 | (compressor (first %compressors)) |
5895ec8a | 80 | localstatedir? |
850edd77 LC |
81 | (symlinks '()) |
82 | (tar tar)) | |
239c2266 | 83 | "Return a self-contained tarball containing a store initialized with the |
6b63c43e LC |
84 | closure of PROFILE, a derivation. The tarball contains /gnu/store; if |
85 | LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db | |
5895ec8a LC |
86 | with a properly initialized store database. |
87 | ||
88 | SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be | |
89 | added to the pack." | |
239c2266 LC |
90 | (define build |
91 | (with-imported-modules '((guix build utils) | |
92 | (guix build store-copy) | |
93 | (gnu build install)) | |
94 | #~(begin | |
95 | (use-modules (guix build utils) | |
5895ec8a LC |
96 | (gnu build install) |
97 | (srfi srfi-1) | |
98 | (srfi srfi-26) | |
99 | (ice-9 match)) | |
239c2266 LC |
100 | |
101 | (define %root "root") | |
102 | ||
5895ec8a LC |
103 | (define symlink->directives |
104 | ;; Return "populate directives" to make the given symlink and its | |
105 | ;; parent directories. | |
106 | (match-lambda | |
107 | ((source '-> target) | |
108 | (let ((target (string-append #$profile "/" target))) | |
109 | `((directory ,(dirname source)) | |
110 | (,source -> ,target)))))) | |
111 | ||
112 | (define directives | |
113 | ;; Fully-qualified symlinks. | |
114 | (append-map symlink->directives '#$symlinks)) | |
115 | ||
850edd77 LC |
116 | ;; The --sort option was added to GNU tar in version 1.28, released |
117 | ;; 2014-07-28. For testing, we use the bootstrap tar, which is | |
118 | ;; older and doesn't support it. | |
119 | (define tar-supports-sort? | |
120 | (zero? (system* (string-append #+tar "/bin/tar") | |
121 | "cf" "/dev/null" "--files-from=/dev/null" | |
122 | "--sort=name"))) | |
123 | ||
239c2266 LC |
124 | ;; We need Guix here for 'guix-register'. |
125 | (setenv "PATH" | |
6b63c43e LC |
126 | (string-append #$(if localstatedir? |
127 | (file-append guix "/sbin:") | |
128 | "") | |
48b44430 | 129 | #$tar "/bin")) |
239c2266 LC |
130 | |
131 | ;; Note: there is not much to gain here with deduplication and | |
132 | ;; there is the overhead of the '.links' directory, so turn it | |
133 | ;; off. | |
134 | (populate-single-profile-directory %root | |
135 | #:profile #$profile | |
136 | #:closure "profile" | |
6b63c43e LC |
137 | #:deduplicate? #f |
138 | #:register? #$localstatedir?) | |
239c2266 | 139 | |
5895ec8a LC |
140 | ;; Create SYMLINKS. |
141 | (for-each (cut evaluate-populate-directive <> %root) | |
142 | directives) | |
143 | ||
239c2266 LC |
144 | ;; Create the tarball. Use GNU format so there's no file name |
145 | ;; length limitation. | |
146 | (with-directory-excursion %root | |
5895ec8a | 147 | (exit |
36f213fb | 148 | (zero? (apply system* "tar" |
48b44430 LC |
149 | "-I" |
150 | (string-join '#+(compressor-command compressor)) | |
5895ec8a LC |
151 | "--format=gnu" |
152 | ||
153 | ;; Avoid non-determinism in the archive. Use | |
154 | ;; mtime = 1, not zero, because that is what the | |
155 | ;; daemon does for files in the store (see the | |
156 | ;; 'mtimeStore' constant in local-store.cc.) | |
850edd77 | 157 | (if tar-supports-sort? "--sort=name" "--mtime=@1") |
5895ec8a LC |
158 | "--mtime=@1" ;for files in /var/guix |
159 | "--owner=root:0" | |
160 | "--group=root:0" | |
161 | ||
162 | "--check-links" | |
163 | "-cvf" #$output | |
164 | ;; Avoid adding / and /var to the tarball, so | |
165 | ;; that the ownership and permissions of those | |
166 | ;; directories will not be overwritten when | |
167 | ;; extracting the archive. Do not include /root | |
168 | ;; because the root account might have a | |
169 | ;; different home directory. | |
170 | #$@(if localstatedir? | |
171 | '("./var/guix") | |
172 | '()) | |
173 | ||
174 | (string-append "." (%store-directory)) | |
175 | ||
176 | (delete-duplicates | |
177 | (filter-map (match-lambda | |
178 | (('directory directory) | |
179 | (string-append "." directory)) | |
180 | (_ #f)) | |
181 | directives))))))))) | |
239c2266 LC |
182 | |
183 | (gexp->derivation (string-append name ".tar." | |
184 | (compressor-extension compressor)) | |
185 | build | |
186 | #:references-graphs `(("profile" ,profile)))) | |
187 | ||
b1edfbc3 | 188 | (define* (docker-image name profile |
5461115e LC |
189 | #:key target |
190 | deduplicate? | |
b1edfbc3 LC |
191 | (compressor (first %compressors)) |
192 | localstatedir? | |
193 | (symlinks '()) | |
194 | (tar tar)) | |
195 | "Return a derivation to construct a Docker image of PROFILE. The | |
196 | image is a tarball conforming to the Docker Image Specification, compressed | |
5461115e LC |
197 | with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it |
198 | must a be a GNU triplet and it is used to derive the architecture metadata in | |
199 | the image." | |
9e84ea36 | 200 | ;; FIXME: Honor LOCALSTATEDIR?. |
b1edfbc3 LC |
201 | (define not-config? |
202 | (match-lambda | |
203 | (('guix 'config) #f) | |
204 | (('guix rest ...) #t) | |
205 | (('gnu rest ...) #t) | |
206 | (rest #f))) | |
207 | ||
208 | (define config | |
209 | ;; (guix config) module for consumption by (guix gcrypt). | |
210 | (scheme-file "gcrypt-config.scm" | |
211 | #~(begin | |
212 | (define-module (guix config) | |
213 | #:export (%libgcrypt)) | |
214 | ||
215 | ;; XXX: Work around <http://bugs.gnu.org/15602>. | |
216 | (eval-when (expand load eval) | |
217 | (define %libgcrypt | |
218 | #+(file-append libgcrypt "/lib/libgcrypt")))))) | |
219 | ||
96afb480 LC |
220 | (define json |
221 | ;; Pick the guile-json package that corresponds to the Guile used to build | |
222 | ;; derivations. | |
223 | (if (string-prefix? "2.0" (package-version (default-guile))) | |
224 | guile2.0-json | |
225 | guile-json)) | |
226 | ||
b1edfbc3 LC |
227 | (define build |
228 | (with-imported-modules `(,@(source-module-closure '((guix docker)) | |
229 | #:select? not-config?) | |
230 | ((guix config) => ,config)) | |
231 | #~(begin | |
232 | ;; Guile-JSON is required by (guix docker). | |
233 | (add-to-load-path | |
96afb480 | 234 | (string-append #+json "/share/guile/site/" |
b1edfbc3 LC |
235 | (effective-version))) |
236 | ||
84dda5a9 | 237 | (use-modules (guix docker) (srfi srfi-19)) |
b1edfbc3 | 238 | |
48b44430 | 239 | (setenv "PATH" (string-append #$tar "/bin")) |
b1edfbc3 LC |
240 | |
241 | (build-docker-image #$output #$profile | |
5461115e | 242 | #:system (or #$target (utsname:machine (uname))) |
b1edfbc3 | 243 | #:closure "profile" |
9e84ea36 | 244 | #:symlinks '#$symlinks |
84dda5a9 LC |
245 | #:compressor '#$(compressor-command compressor) |
246 | #:creation-time (make-time time-utc 0 1))))) | |
b1edfbc3 LC |
247 | |
248 | (gexp->derivation (string-append name ".tar." | |
249 | (compressor-extension compressor)) | |
250 | build | |
251 | #:references-graphs `(("profile" ,profile)))) | |
239c2266 LC |
252 | |
253 | \f | |
254 | ;;; | |
255 | ;;; Command-line options. | |
256 | ;;; | |
257 | ||
258 | (define %default-options | |
259 | ;; Alist of default option values. | |
b1edfbc3 LC |
260 | `((format . tarball) |
261 | (system . ,(%current-system)) | |
239c2266 LC |
262 | (substitutes? . #t) |
263 | (graft? . #t) | |
264 | (max-silent-time . 3600) | |
265 | (verbosity . 0) | |
5895ec8a | 266 | (symlinks . ()) |
239c2266 LC |
267 | (compressor . ,(first %compressors)))) |
268 | ||
b1edfbc3 LC |
269 | (define %formats |
270 | ;; Supported pack formats. | |
271 | `((tarball . ,self-contained-tarball) | |
272 | (docker . ,docker-image))) | |
273 | ||
239c2266 LC |
274 | (define %options |
275 | ;; Specifications of the command-line options. | |
276 | (cons* (option '(#\h "help") #f #f | |
277 | (lambda args | |
278 | (show-help) | |
279 | (exit 0))) | |
280 | (option '(#\V "version") #f #f | |
281 | (lambda args | |
282 | (show-version-and-exit "guix pack"))) | |
283 | ||
284 | (option '(#\n "dry-run") #f #f | |
285 | (lambda (opt name arg result) | |
286 | (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) | |
b1edfbc3 LC |
287 | (option '(#\f "format") #t #f |
288 | (lambda (opt name arg result) | |
289 | (alist-cons 'format (string->symbol arg) result))) | |
83cfa024 LC |
290 | (option '(#\e "expression") #t #f |
291 | (lambda (opt name arg result) | |
292 | (alist-cons 'expression arg result))) | |
239c2266 LC |
293 | (option '(#\s "system") #t #f |
294 | (lambda (opt name arg result) | |
295 | (alist-cons 'system arg | |
296 | (alist-delete 'system result eq?)))) | |
5461115e LC |
297 | (option '("target") #t #f |
298 | (lambda (opt name arg result) | |
299 | (alist-cons 'target arg | |
300 | (alist-delete 'target result eq?)))) | |
239c2266 LC |
301 | (option '(#\C "compression") #t #f |
302 | (lambda (opt name arg result) | |
303 | (alist-cons 'compressor (lookup-compressor arg) | |
304 | result))) | |
5895ec8a LC |
305 | (option '(#\S "symlink") #t #f |
306 | (lambda (opt name arg result) | |
db3f2b61 LC |
307 | ;; Note: Using 'string-split' allows us to handle empty |
308 | ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is | |
309 | ;; a symlink to the profile) correctly. | |
310 | (match (string-split arg (char-set #\=)) | |
5895ec8a LC |
311 | ((source target) |
312 | (let ((symlinks (assoc-ref result 'symlinks))) | |
313 | (alist-cons 'symlinks | |
314 | `((,source -> ,target) ,@symlinks) | |
315 | (alist-delete 'symlinks result eq?)))) | |
316 | (x | |
69daee23 | 317 | (leave (G_ "~a: invalid symlink specification~%") |
5895ec8a | 318 | arg))))) |
6b63c43e LC |
319 | (option '("localstatedir") #f #f |
320 | (lambda (opt name arg result) | |
321 | (alist-cons 'localstatedir? #t result))) | |
239c2266 LC |
322 | |
323 | (append %transformation-options | |
324 | %standard-build-options))) | |
325 | ||
326 | (define (show-help) | |
69daee23 | 327 | (display (G_ "Usage: guix pack [OPTION]... PACKAGE... |
239c2266 LC |
328 | Create a bundle of PACKAGE.\n")) |
329 | (show-build-options-help) | |
330 | (newline) | |
331 | (show-transformation-options-help) | |
332 | (newline) | |
69daee23 | 333 | (display (G_ " |
b1edfbc3 | 334 | -f, --format=FORMAT build a pack in the given FORMAT")) |
69daee23 | 335 | (display (G_ " |
83cfa024 | 336 | -e, --expression=EXPR consider the package EXPR evaluates to")) |
69daee23 | 337 | (display (G_ " |
239c2266 | 338 | -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) |
69daee23 | 339 | (display (G_ " |
5461115e | 340 | --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) |
69daee23 | 341 | (display (G_ " |
239c2266 | 342 | -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) |
69daee23 | 343 | (display (G_ " |
5895ec8a | 344 | -S, --symlink=SPEC create symlinks to the profile according to SPEC")) |
69daee23 | 345 | (display (G_ " |
6b63c43e | 346 | --localstatedir include /var/guix in the resulting pack")) |
239c2266 | 347 | (newline) |
69daee23 | 348 | (display (G_ " |
239c2266 | 349 | -h, --help display this help and exit")) |
69daee23 | 350 | (display (G_ " |
239c2266 LC |
351 | -V, --version display version information and exit")) |
352 | (newline) | |
353 | (show-bug-report-information)) | |
354 | ||
355 | \f | |
356 | ;;; | |
357 | ;;; Entry point. | |
358 | ;;; | |
359 | ||
360 | (define (guix-pack . args) | |
361 | (define opts | |
362 | (parse-command-line args %options (list %default-options))) | |
363 | ||
83cfa024 LC |
364 | (define maybe-package-argument |
365 | ;; Given an option pair, return a package, a package/output tuple, or #f. | |
366 | (match-lambda | |
367 | (('argument . spec) | |
368 | (call-with-values | |
369 | (lambda () | |
370 | (specification->package+output spec)) | |
371 | list)) | |
372 | (('expression . exp) | |
373 | (read/eval-package-expression exp)) | |
374 | (x #f))) | |
375 | ||
239c2266 LC |
376 | (with-error-handling |
377 | (parameterize ((%graft? (assoc-ref opts 'graft?))) | |
83cfa024 LC |
378 | (let* ((dry-run? (assoc-ref opts 'dry-run?)) |
379 | (packages (filter-map maybe-package-argument opts)) | |
b1edfbc3 LC |
380 | (pack-format (assoc-ref opts 'format)) |
381 | (name (string-append (symbol->string pack-format) | |
382 | "-pack")) | |
5461115e | 383 | (target (assoc-ref opts 'target)) |
b1edfbc3 LC |
384 | (compressor (assoc-ref opts 'compressor)) |
385 | (symlinks (assoc-ref opts 'symlinks)) | |
386 | (build-image (match (assq-ref %formats pack-format) | |
387 | ((? procedure? proc) proc) | |
388 | (#f | |
69daee23 | 389 | (leave (G_ "~a: unknown pack format") |
b1edfbc3 | 390 | format)))) |
6b63c43e | 391 | (localstatedir? (assoc-ref opts 'localstatedir?))) |
239c2266 | 392 | (with-store store |
2971f39c LC |
393 | ;; Set the build options before we do anything else. |
394 | (set-build-options-from-command-line store opts) | |
395 | ||
239c2266 LC |
396 | (run-with-store store |
397 | (mlet* %store-monad ((profile (profile-derivation | |
5461115e LC |
398 | (packages->manifest packages) |
399 | #:target target)) | |
b1edfbc3 | 400 | (drv (build-image name profile |
5461115e LC |
401 | #:target |
402 | target | |
b1edfbc3 LC |
403 | #:compressor |
404 | compressor | |
405 | #:symlinks | |
406 | symlinks | |
407 | #:localstatedir? | |
408 | localstatedir?))) | |
239c2266 LC |
409 | (mbegin %store-monad |
410 | (show-what-to-build* (list drv) | |
411 | #:use-substitutes? | |
412 | (assoc-ref opts 'substitutes?) | |
413 | #:dry-run? dry-run?) | |
414 | (munless dry-run? | |
415 | (built-derivations (list drv)) | |
416 | (return (format #t "~a~%" | |
417 | (derivation->output-path drv)))))) | |
418 | #:system (assoc-ref opts 'system))))))) |