Commit | Line | Data |
---|---|---|
523e4896 | 1 | ;;; GNU Guix --- Functional package management for GNU |
e87f0591 | 2 | ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
b8300494 | 3 | ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> |
523e4896 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 system) | |
b25937e3 | 21 | #:use-module (guix config) |
523e4896 LC |
22 | #:use-module (guix ui) |
23 | #:use-module (guix store) | |
72b9d60d | 24 | #:use-module (guix gexp) |
523e4896 LC |
25 | #:use-module (guix derivations) |
26 | #:use-module (guix packages) | |
27 | #:use-module (guix utils) | |
28 | #:use-module (guix monads) | |
5b516ef3 | 29 | #:use-module (guix records) |
b25937e3 | 30 | #:use-module (guix profiles) |
88981dd3 | 31 | #:use-module (guix scripts) |
523e4896 | 32 | #:use-module (guix scripts build) |
8fb58371 | 33 | #:use-module (guix graph) |
d6c3267a | 34 | #:use-module (guix scripts graph) |
72b9d60d | 35 | #:use-module (guix build utils) |
548f7a8f | 36 | #:use-module (gnu build install) |
7889394e | 37 | #:use-module (gnu system) |
9110c2e9 | 38 | #:use-module (gnu system file-systems) |
1c8a81b1 | 39 | #:use-module (gnu system linux-container) |
523e4896 | 40 | #:use-module (gnu system vm) |
c79d54fe | 41 | #:use-module (gnu system grub) |
d6c3267a | 42 | #:use-module (gnu services) |
0190c1c0 | 43 | #:use-module (gnu services shepherd) |
c79d54fe | 44 | #:use-module (gnu packages grub) |
523e4896 | 45 | #:use-module (srfi srfi-1) |
906b1b09 | 46 | #:use-module (srfi srfi-19) |
72b9d60d | 47 | #:use-module (srfi srfi-26) |
65797bff LC |
48 | #:use-module (srfi srfi-34) |
49 | #:use-module (srfi srfi-35) | |
523e4896 LC |
50 | #:use-module (srfi srfi-37) |
51 | #:use-module (ice-9 match) | |
731b9962 LC |
52 | #:export (guix-system |
53 | read-operating-system)) | |
523e4896 | 54 | |
8e42796b LC |
55 | \f |
56 | ;;; | |
57 | ;;; Operating system declaration. | |
58 | ;;; | |
59 | ||
523e4896 LC |
60 | (define %user-module |
61 | ;; Module in which the machine description file is loaded. | |
7ea1432e DT |
62 | (make-user-module '((gnu system) |
63 | (gnu services) | |
64 | (gnu system shadow)))) | |
523e4896 LC |
65 | |
66 | (define (read-operating-system file) | |
67 | "Read the operating-system declaration from FILE and return it." | |
7ea1432e | 68 | (load* file %user-module)) |
523e4896 | 69 | |
523e4896 | 70 | |
8e42796b LC |
71 | \f |
72 | ;;; | |
73 | ;;; Installation. | |
74 | ;;; | |
75 | ||
76 | ;; TODO: Factorize. | |
77 | (define references* | |
78 | (store-lift references)) | |
79 | (define topologically-sorted* | |
80 | (store-lift topologically-sorted)) | |
8e42796b LC |
81 | |
82 | ||
8334cf5b LC |
83 | (define* (copy-item item target |
84 | #:key (log-port (current-error-port))) | |
c56d19fb | 85 | "Copy ITEM to the store under root directory TARGET and register it." |
8e42796b | 86 | (mlet* %store-monad ((refs (references* item))) |
a52127c0 LC |
87 | (let ((dest (string-append target item)) |
88 | (state (string-append target "/var/guix"))) | |
8e42796b | 89 | (format log-port "copying '~a'...~%" item) |
78acff7c LC |
90 | |
91 | ;; Remove DEST if it exists to make sure that (1) we do not fail badly | |
92 | ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and | |
93 | ;; (2) we end up with the right contents. | |
94 | (when (file-exists? dest) | |
95 | (delete-file-recursively dest)) | |
96 | ||
8e42796b LC |
97 | (copy-recursively item dest |
98 | #:log (%make-void-port "w")) | |
99 | ||
100 | ;; Register ITEM; as a side-effect, it resets timestamps, etc. | |
a52127c0 LC |
101 | ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid |
102 | ;; reproducing the user's current settings; see | |
103 | ;; <http://bugs.gnu.org/18049>. | |
8e42796b LC |
104 | (unless (register-path item |
105 | #:prefix target | |
a52127c0 | 106 | #:state-directory state |
8e42796b LC |
107 | #:references refs) |
108 | (leave (_ "failed to register '~a' under '~a'~%") | |
109 | item target)) | |
110 | ||
111 | (return #t)))) | |
112 | ||
8334cf5b LC |
113 | (define* (copy-closure item target |
114 | #:key (log-port (current-error-port))) | |
115 | "Copy ITEM and all its dependencies to the store under root directory | |
116 | TARGET, and register them." | |
117 | (mlet* %store-monad ((refs (references* item)) | |
118 | (to-copy (topologically-sorted* | |
119 | (delete-duplicates (cons item refs) | |
120 | string=?)))) | |
121 | (sequence %store-monad | |
122 | (map (cut copy-item <> target #:log-port log-port) | |
123 | to-copy)))) | |
124 | ||
c3e79cde LC |
125 | (define (install-grub* grub.cfg device target) |
126 | "This is a variant of 'install-grub' with error handling, lifted in | |
127 | %STORE-MONAD" | |
6412e58a LC |
128 | (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) |
129 | (temp-gc-root (string-append gc-root ".new")) | |
130 | (delete-file (lift1 delete-file %store-monad)) | |
131 | (make-symlink (lift2 switch-symlinks %store-monad)) | |
132 | (rename (lift2 rename-file %store-monad))) | |
39d1f82b | 133 | (mbegin %store-monad |
6412e58a LC |
134 | ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when |
135 | ;; 'install-grub' completes (being a bit paranoid.) | |
136 | (make-symlink temp-gc-root grub.cfg) | |
137 | ||
39d1f82b | 138 | (munless (false-if-exception (install-grub grub.cfg device target)) |
6412e58a | 139 | (delete-file temp-gc-root) |
39d1f82b LC |
140 | (leave (_ "failed to install GRUB on device '~a'~%") device)) |
141 | ||
142 | ;; Register GRUB.CFG as a GC root so that its dependencies (background | |
143 | ;; image, font, etc.) are not reclaimed. | |
6412e58a | 144 | (rename temp-gc-root gc-root)))) |
c3e79cde | 145 | |
8e42796b | 146 | (define* (install os-drv target |
c79d54fe LC |
147 | #:key (log-port (current-output-port)) |
148 | grub? grub.cfg device) | |
f245b03d LC |
149 | "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to |
150 | directory TARGET. TARGET must be an absolute directory name since that's what | |
151 | 'guix-register' expects. | |
c79d54fe LC |
152 | |
153 | When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." | |
8e42796b LC |
154 | (define (maybe-copy to-copy) |
155 | (with-monad %store-monad | |
156 | (if (string=? target "/") | |
157 | (begin | |
158 | (warning (_ "initializing the current root file system~%")) | |
159 | (return #t)) | |
160 | (begin | |
161 | ;; Make sure the target store exists. | |
162 | (mkdir-p (string-append target (%store-prefix))) | |
163 | ||
164 | ;; Copy items to the new store. | |
8334cf5b | 165 | (copy-closure to-copy target #:log-port log-port))))) |
8e42796b | 166 | |
4a35a866 LC |
167 | ;; Make sure TARGET is root-owned when running as root, but still allow |
168 | ;; non-root uses (useful for testing.) See | |
169 | ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>. | |
170 | (if (zero? (geteuid)) | |
171 | (chown target 0 0) | |
172 | (warning (_ "not running as 'root', so \ | |
173 | the ownership of '~a' may be incorrect!~%") | |
174 | target)) | |
175 | ||
176 | (chmod target #o755) | |
cc7fa592 | 177 | (let ((os-dir (derivation->output-path os-drv)) |
c9e46f1c LC |
178 | (format (lift format %store-monad)) |
179 | (populate (lift2 populate-root-file-system %store-monad))) | |
cc7fa592 LC |
180 | |
181 | (mbegin %store-monad | |
f245b03d LC |
182 | ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's |
183 | ;; background image and so on. | |
184 | (maybe-copy grub.cfg) | |
cc7fa592 LC |
185 | |
186 | ;; Create a bunch of additional files. | |
187 | (format log-port "populating '~a'...~%" target) | |
188 | (populate os-dir target) | |
189 | ||
c3e79cde LC |
190 | (mwhen grub? |
191 | (install-grub* grub.cfg device target))))) | |
72b9d60d | 192 | |
523e4896 | 193 | \f |
b25937e3 LC |
194 | ;;; |
195 | ;;; Reconfiguration. | |
196 | ;;; | |
197 | ||
198 | (define %system-profile | |
199 | ;; The system profile. | |
200 | (string-append %state-directory "/profiles/system")) | |
201 | ||
720ee245 LC |
202 | (define-syntax-rule (save-environment-excursion body ...) |
203 | "Save the current environment variables, run BODY..., and restore them." | |
204 | (let ((env (environ))) | |
205 | (dynamic-wind | |
206 | (const #t) | |
207 | (lambda () | |
208 | body ...) | |
209 | (lambda () | |
210 | (environ env))))) | |
211 | ||
8e42796b LC |
212 | (define* (switch-to-system os |
213 | #:optional (profile %system-profile)) | |
214 | "Make a new generation of PROFILE pointing to the directory of OS, switch to | |
215 | it atomically, and then run OS's activation script." | |
216 | (mlet* %store-monad ((drv (operating-system-derivation os)) | |
217 | (script (operating-system-activation-script os))) | |
218 | (let* ((system (derivation->output-path drv)) | |
219 | (number (+ 1 (generation-number profile))) | |
220 | (generation (generation-file-name profile number))) | |
221 | (symlink system generation) | |
222 | (switch-symlinks profile generation) | |
223 | ||
224 | (format #t (_ "activating system...~%")) | |
720ee245 LC |
225 | |
226 | ;; The activation script may change $PATH, among others, so protect | |
227 | ;; against that. | |
228 | (return (save-environment-excursion | |
6d49355d LC |
229 | ;; Tell 'activate-current-system' what the new system is. |
230 | (setenv "GUIX_NEW_SYSTEM" system) | |
231 | ||
720ee245 | 232 | (primitive-load (derivation->output-path script)))) |
8e42796b LC |
233 | |
234 | ;; TODO: Run 'deco reload ...'. | |
235 | ))) | |
b25937e3 LC |
236 | |
237 | (define-syntax-rule (unless-file-not-found exp) | |
238 | (catch 'system-error | |
239 | (lambda () | |
240 | exp) | |
241 | (lambda args | |
242 | (if (= ENOENT (system-error-errno args)) | |
243 | #f | |
244 | (apply throw args))))) | |
245 | ||
906b1b09 LC |
246 | (define (seconds->string seconds) |
247 | "Return a string representing the date for SECONDS." | |
248 | (let ((time (make-time time-utc 0 seconds))) | |
249 | (date->string (time-utc->date time) | |
250 | "~Y-~m-~d ~H:~M"))) | |
251 | ||
b25937e3 LC |
252 | (define* (previous-grub-entries #:optional (profile %system-profile)) |
253 | "Return a list of 'menu-entry' for the generations of PROFILE." | |
906b1b09 | 254 | (define (system->grub-entry system number time) |
b25937e3 | 255 | (unless-file-not-found |
b8300494 AK |
256 | (let* ((file (string-append system "/parameters")) |
257 | (params (call-with-input-file file | |
258 | read-boot-parameters)) | |
259 | (label (boot-parameters-label params)) | |
260 | (root (boot-parameters-root-device params)) | |
261 | (kernel (boot-parameters-kernel params)) | |
262 | (kernel-arguments (boot-parameters-kernel-arguments params))) | |
263 | (menu-entry | |
264 | (label (string-append label " (#" | |
265 | (number->string number) ", " | |
266 | (seconds->string time) ")")) | |
267 | (linux kernel) | |
268 | (linux-arguments | |
269 | (cons* (string-append "--root=" root) | |
270 | #~(string-append "--system=" #$system) | |
271 | #~(string-append "--load=" #$system "/boot") | |
272 | kernel-arguments)) | |
273 | (initrd #~(string-append #$system "/initrd")))))) | |
b25937e3 | 274 | |
906b1b09 LC |
275 | (let* ((numbers (generation-numbers profile)) |
276 | (systems (map (cut generation-file-name profile <>) | |
277 | numbers)) | |
278 | (times (map (lambda (system) | |
279 | (unless-file-not-found | |
280 | (stat:mtime (lstat system)))) | |
281 | systems))) | |
282 | (filter-map system->grub-entry systems numbers times))) | |
b25937e3 LC |
283 | |
284 | \f | |
d6c3267a | 285 | ;;; |
6f305ea5 | 286 | ;;; Graphs. |
d6c3267a LC |
287 | ;;; |
288 | ||
289 | (define (service-node-label service) | |
290 | "Return a label to represent SERVICE." | |
291 | (let ((type (service-kind service)) | |
292 | (value (service-parameters service))) | |
293 | (string-append (symbol->string (service-type-name type)) | |
294 | (cond ((or (number? value) (symbol? value)) | |
295 | (string-append " " (object->string value))) | |
296 | ((string? value) | |
297 | (string-append " " value)) | |
298 | ((file-system? value) | |
299 | (string-append " " (file-system-mount-point value))) | |
300 | (else | |
301 | ""))))) | |
302 | ||
303 | (define (service-node-type services) | |
304 | "Return a node type for SERVICES. Since <service> instances are not | |
305 | self-contained (they express dependencies on service types, not on services), | |
306 | we have to create the 'edges' procedure dynamically as a function of the full | |
307 | list of services." | |
308 | (node-type | |
309 | (name "service") | |
310 | (description "the DAG of services") | |
311 | (identifier (lift1 object-address %store-monad)) | |
312 | (label service-node-label) | |
313 | (edges (lift1 (service-back-edges services) %store-monad)))) | |
314 | ||
6f305ea5 | 315 | (define (dmd-service-node-label service) |
d4053c71 AK |
316 | "Return a label for a node representing a <shepherd-service>." |
317 | (string-join (map symbol->string (shepherd-service-provision service)))) | |
6f305ea5 LC |
318 | |
319 | (define (dmd-service-node-type services) | |
d4053c71 | 320 | "Return a node type for SERVICES, a list of <shepherd-service>." |
6f305ea5 LC |
321 | (node-type |
322 | (name "dmd-service") | |
323 | (description "the dependency graph of dmd services") | |
324 | (identifier (lift1 dmd-service-node-label %store-monad)) | |
325 | (label dmd-service-node-label) | |
d4053c71 | 326 | (edges (lift1 (shepherd-service-back-edges services) %store-monad)))) |
d6c3267a LC |
327 | |
328 | \f | |
65797bff LC |
329 | ;;; |
330 | ;;; Generations. | |
331 | ;;; | |
332 | ||
333 | (define* (display-system-generation number | |
334 | #:optional (profile %system-profile)) | |
335 | "Display a summary of system generation NUMBER in a human-readable format." | |
336 | (unless (zero? number) | |
337 | (let* ((generation (generation-file-name profile number)) | |
338 | (param-file (string-append generation "/parameters")) | |
b8300494 AK |
339 | (params (call-with-input-file param-file read-boot-parameters)) |
340 | (label (boot-parameters-label params)) | |
341 | (root (boot-parameters-root-device params)) | |
342 | (kernel (boot-parameters-kernel params))) | |
65797bff LC |
343 | (display-generation profile number) |
344 | (format #t (_ " file name: ~a~%") generation) | |
345 | (format #t (_ " canonical file name: ~a~%") (readlink* generation)) | |
b8300494 AK |
346 | ;; TRANSLATORS: Please preserve the two-space indentation. |
347 | (format #t (_ " label: ~a~%") label) | |
348 | (format #t (_ " root device: ~a~%") root) | |
349 | (format #t (_ " kernel: ~a~%") kernel)))) | |
65797bff LC |
350 | |
351 | (define* (list-generations pattern #:optional (profile %system-profile)) | |
352 | "Display in a human-readable format all the system generations matching | |
353 | PATTERN, a string. When PATTERN is #f, display all the system generations." | |
354 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
355 | (raise (condition (&profile-not-found-error | |
356 | (profile profile))))) | |
357 | ((string-null? pattern) | |
358 | (for-each display-system-generation (profile-generations profile))) | |
359 | ((matching-generations pattern profile) | |
360 | => | |
361 | (lambda (numbers) | |
362 | (if (null-list? numbers) | |
363 | (exit 1) | |
364 | (leave-on-EPIPE | |
365 | (for-each display-system-generation numbers))))) | |
366 | (else | |
367 | (leave (_ "invalid syntax: ~a~%") pattern)))) | |
368 | ||
369 | \f | |
8e42796b LC |
370 | ;;; |
371 | ;;; Action. | |
372 | ;;; | |
373 | ||
374 | (define* (system-derivation-for-action os action | |
0276f697 | 375 | #:key image-size full-boot? mappings) |
8e42796b LC |
376 | "Return as a monadic value the derivation for OS according to ACTION." |
377 | (case action | |
378 | ((build init reconfigure) | |
379 | (operating-system-derivation os)) | |
1c8a81b1 DT |
380 | ((container) |
381 | (container-script os #:mappings mappings)) | |
8e42796b LC |
382 | ((vm-image) |
383 | (system-qemu-image os #:disk-image-size image-size)) | |
384 | ((vm) | |
6aa260af LC |
385 | (system-qemu-image/shared-store-script os |
386 | #:full-boot? full-boot? | |
0276f697 LC |
387 | #:disk-image-size image-size |
388 | #:mappings mappings)) | |
8e42796b LC |
389 | ((disk-image) |
390 | (system-disk-image os #:disk-image-size image-size)))) | |
391 | ||
8e42796b | 392 | (define* (perform-action action os |
f3f427c2 | 393 | #:key grub? dry-run? derivations-only? |
8e42796b | 394 | use-substitutes? device target |
0276f697 LC |
395 | image-size full-boot? |
396 | (mappings '())) | |
8e42796b LC |
397 | "Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is |
398 | the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE | |
399 | is the size of the image to be built, for the 'vm-image' and 'disk-image' | |
ab11f0be | 400 | actions. FULL-BOOT? is used for the 'vm' action; it determines whether to |
f3f427c2 LC |
401 | boot directly to the kernel or to the bootloader. |
402 | ||
403 | When DERIVATIONS-ONLY? is true, print the derivation file name(s) without | |
404 | building anything." | |
405 | (define println | |
406 | (cut format #t "~a~%" <>)) | |
407 | ||
8e42796b LC |
408 | (mlet* %store-monad |
409 | ((sys (system-derivation-for-action os action | |
ab11f0be | 410 | #:image-size image-size |
0276f697 LC |
411 | #:full-boot? full-boot? |
412 | #:mappings mappings)) | |
8e42796b | 413 | (grub (package->derivation grub)) |
1c8a81b1 DT |
414 | (grub.cfg (if (eq? 'container action) |
415 | (return #f) | |
416 | (operating-system-grub.cfg os | |
417 | (if (eq? 'init action) | |
418 | '() | |
419 | (previous-grub-entries))))) | |
a7043618 LC |
420 | |
421 | ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if | |
422 | ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC | |
423 | ;; root. See <http://bugs.gnu.org/21068>. | |
424 | (drvs -> (if (memq action '(init reconfigure)) | |
425 | (if grub? | |
426 | (list sys grub.cfg grub) | |
427 | (list sys grub.cfg)) | |
8e42796b | 428 | (list sys))) |
f3f427c2 LC |
429 | (% (if derivations-only? |
430 | (return (for-each (compose println derivation-file-name) | |
431 | drvs)) | |
432 | (maybe-build drvs #:dry-run? dry-run? | |
433 | #:use-substitutes? use-substitutes?)))) | |
8e42796b | 434 | |
f3f427c2 | 435 | (if (or dry-run? derivations-only?) |
8e42796b LC |
436 | (return #f) |
437 | (begin | |
f3f427c2 LC |
438 | (for-each (compose println derivation->output-path) |
439 | drvs) | |
8e42796b LC |
440 | |
441 | ;; Make sure GRUB is accessible. | |
442 | (when grub? | |
443 | (let ((prefix (derivation->output-path grub))) | |
444 | (setenv "PATH" | |
445 | (string-append prefix "/bin:" prefix "/sbin:" | |
446 | (getenv "PATH"))))) | |
447 | ||
448 | (case action | |
449 | ((reconfigure) | |
c3e79cde LC |
450 | (mbegin %store-monad |
451 | (switch-to-system os) | |
452 | (mwhen grub? | |
453 | (install-grub* (derivation->output-path grub.cfg) | |
454 | device "/")))) | |
8e42796b LC |
455 | ((init) |
456 | (newline) | |
457 | (format #t (_ "initializing operating system under '~a'...~%") | |
458 | target) | |
459 | (install sys (canonicalize-path target) | |
460 | #:grub? grub? | |
461 | #:grub.cfg (derivation->output-path grub.cfg) | |
462 | #:device device)) | |
463 | (else | |
464 | ;; All we had to do was to build SYS. | |
465 | (return (derivation->output-path sys)))))))) | |
466 | ||
d6c3267a LC |
467 | (define (export-extension-graph os port) |
468 | "Export the service extension graph of OS to PORT." | |
469 | (let* ((services (operating-system-services os)) | |
d62e201c LC |
470 | (system (find (lambda (service) |
471 | (eq? (service-kind service) system-service-type)) | |
d6c3267a | 472 | services))) |
d62e201c | 473 | (export-graph (list system) (current-output-port) |
d6c3267a LC |
474 | #:node-type (service-node-type services) |
475 | #:reverse-edges? #t))) | |
476 | ||
6f305ea5 | 477 | (define (export-dmd-graph os port) |
d4053c71 AK |
478 | "Export the graph of shepherd services of OS to PORT." |
479 | (let* ((services (operating-system-services os)) | |
480 | (pid1 (fold-services services | |
481 | #:target-type shepherd-root-service-type)) | |
482 | (shepherds (service-parameters pid1)) ;list of <shepherd-service> | |
483 | (sinks (filter (lambda (service) | |
484 | (null? (shepherd-service-requirement service))) | |
485 | shepherds))) | |
6f305ea5 LC |
486 | (export-graph sinks (current-output-port) |
487 | #:node-type (dmd-service-node-type dmds) | |
488 | #:reverse-edges? #t))) | |
489 | ||
8e42796b | 490 | \f |
523e4896 LC |
491 | ;;; |
492 | ;;; Options. | |
493 | ;;; | |
494 | ||
495 | (define (show-help) | |
65797bff | 496 | (display (_ "Usage: guix system [OPTION] ACTION [FILE] |
523e4896 | 497 | Build the operating system declared in FILE according to ACTION.\n")) |
7889394e LC |
498 | (newline) |
499 | (display (_ "The valid values for ACTION are:\n")) | |
2a4e2e4b | 500 | (newline) |
7889394e | 501 | (display (_ "\ |
2a4e2e4b | 502 | reconfigure switch to a new operating system configuration\n")) |
65797bff LC |
503 | (display (_ "\ |
504 | list-generations list the system generations\n")) | |
b25937e3 | 505 | (display (_ "\ |
2a4e2e4b | 506 | build build the operating system without installing anything\n")) |
1c8a81b1 | 507 | (display (_ "\ |
fbd213a8 | 508 | container build a container that shares the host's store\n")) |
7889394e | 509 | (display (_ "\ |
2a4e2e4b | 510 | vm build a virtual machine image that shares the host's store\n")) |
7889394e | 511 | (display (_ "\ |
2a4e2e4b | 512 | vm-image build a freestanding virtual machine image\n")) |
72b9d60d | 513 | (display (_ "\ |
2a4e2e4b | 514 | disk-image build a disk image, suitable for a USB stick\n")) |
fb729425 | 515 | (display (_ "\ |
d6c3267a LC |
516 | init initialize a root file system to run GNU\n")) |
517 | (display (_ "\ | |
518 | extension-graph emit the service extension graph in Dot format\n")) | |
6f305ea5 LC |
519 | (display (_ "\ |
520 | dmd-graph emit the graph of dmd services in Dot format\n")) | |
7889394e | 521 | |
523e4896 | 522 | (show-build-options-help) |
f3f427c2 LC |
523 | (display (_ " |
524 | -d, --derivation return the derivation of the given system")) | |
db030303 LC |
525 | (display (_ " |
526 | --on-error=STRATEGY | |
527 | apply STRATEGY when an error occurs while reading FILE")) | |
2e7b5cea LC |
528 | (display (_ " |
529 | --image-size=SIZE for 'vm-image', produce an image of SIZE")) | |
c79d54fe LC |
530 | (display (_ " |
531 | --no-grub for 'init', do not install GRUB")) | |
0276f697 LC |
532 | (display (_ " |
533 | --share=SPEC for 'vm', share host file system according to SPEC")) | |
534 | (display (_ " | |
535 | --expose=SPEC for 'vm', expose host file system according to SPEC")) | |
ab11f0be LC |
536 | (display (_ " |
537 | --full-boot for 'vm', make a full boot sequence")) | |
523e4896 LC |
538 | (newline) |
539 | (display (_ " | |
540 | -h, --help display this help and exit")) | |
541 | (display (_ " | |
542 | -V, --version display version information and exit")) | |
543 | (newline) | |
544 | (show-bug-report-information)) | |
545 | ||
546 | (define %options | |
547 | ;; Specifications of the command-line options. | |
548 | (cons* (option '(#\h "help") #f #f | |
549 | (lambda args | |
550 | (show-help) | |
551 | (exit 0))) | |
552 | (option '(#\V "version") #f #f | |
553 | (lambda args | |
554 | (show-version-and-exit "guix system"))) | |
f3f427c2 LC |
555 | (option '(#\d "derivation") #f #f |
556 | (lambda (opt name arg result) | |
557 | (alist-cons 'derivations-only? #t result))) | |
db030303 LC |
558 | (option '("on-error") #t #f |
559 | (lambda (opt name arg result) | |
560 | (alist-cons 'on-error (string->symbol arg) | |
561 | result))) | |
2e7b5cea LC |
562 | (option '("image-size") #t #f |
563 | (lambda (opt name arg result) | |
564 | (alist-cons 'image-size (size->number arg) | |
565 | result))) | |
c79d54fe LC |
566 | (option '("no-grub") #f #f |
567 | (lambda (opt name arg result) | |
6e1a7d17 | 568 | (alist-cons 'install-grub? #f result))) |
ab11f0be LC |
569 | (option '("full-boot") #f #f |
570 | (lambda (opt name arg result) | |
571 | (alist-cons 'full-boot? #t result))) | |
0276f697 LC |
572 | |
573 | (option '("share") #t #f | |
574 | (lambda (opt name arg result) | |
575 | (alist-cons 'file-system-mapping | |
576 | (specification->file-system-mapping arg #t) | |
577 | result))) | |
578 | (option '("expose") #t #f | |
579 | (lambda (opt name arg result) | |
580 | (alist-cons 'file-system-mapping | |
581 | (specification->file-system-mapping arg #f) | |
582 | result))) | |
583 | ||
523e4896 LC |
584 | (option '(#\n "dry-run") #f #f |
585 | (lambda (opt name arg result) | |
586 | (alist-cons 'dry-run? #t result))) | |
df2ce343 LC |
587 | (option '(#\s "system") #t #f |
588 | (lambda (opt name arg result) | |
589 | (alist-cons 'system arg | |
590 | (alist-delete 'system result eq?)))) | |
523e4896 LC |
591 | %standard-build-options)) |
592 | ||
593 | (define %default-options | |
594 | ;; Alist of default option values. | |
595 | `((system . ,(%current-system)) | |
596 | (substitutes? . #t) | |
597 | (build-hook? . #t) | |
598 | (max-silent-time . 3600) | |
2e7b5cea | 599 | (verbosity . 0) |
c79d54fe LC |
600 | (image-size . ,(* 900 (expt 2 20))) |
601 | (install-grub? . #t))) | |
523e4896 LC |
602 | |
603 | \f | |
604 | ;;; | |
605 | ;;; Entry point. | |
606 | ;;; | |
607 | ||
deaab8e3 | 608 | (define (process-action action args opts) |
65797bff LC |
609 | "Process ACTION, a sub-command, with the arguments are listed in ARGS. |
610 | ACTION must be one of the sub-commands that takes an operating system | |
611 | declaration as an argument (a file name.) OPTS is the raw alist of options | |
612 | resulting from command-line parsing." | |
deaab8e3 LC |
613 | (let* ((file (match args |
614 | (() #f) | |
615 | ((x . _) x))) | |
616 | (system (assoc-ref opts 'system)) | |
617 | (os (if file | |
618 | (load* file %user-module | |
619 | #:on-error (assoc-ref opts 'on-error)) | |
620 | (leave (_ "no configuration file specified~%")))) | |
621 | ||
622 | (dry? (assoc-ref opts 'dry-run?)) | |
623 | (grub? (assoc-ref opts 'install-grub?)) | |
624 | (target (match args | |
625 | ((first second) second) | |
626 | (_ #f))) | |
627 | (device (and grub? | |
628 | (grub-configuration-device | |
629 | (operating-system-bootloader os))))) | |
630 | ||
631 | (with-store store | |
632 | (set-build-options-from-command-line store opts) | |
633 | ||
634 | (run-with-store store | |
635 | (mbegin %store-monad | |
636 | (set-guile-for-build (default-guile)) | |
637 | (case action | |
638 | ((extension-graph) | |
639 | (export-extension-graph os (current-output-port))) | |
640 | ((dmd-graph) | |
641 | (export-dmd-graph os (current-output-port))) | |
642 | (else | |
643 | (perform-action action os | |
644 | #:dry-run? dry? | |
645 | #:derivations-only? (assoc-ref opts | |
646 | 'derivations-only?) | |
647 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
648 | #:image-size (assoc-ref opts 'image-size) | |
649 | #:full-boot? (assoc-ref opts 'full-boot?) | |
650 | #:mappings (filter-map (match-lambda | |
651 | (('file-system-mapping . m) | |
652 | m) | |
653 | (_ #f)) | |
654 | opts) | |
655 | #:grub? grub? | |
656 | #:target target #:device device)))) | |
657 | #:system system)))) | |
658 | ||
65797bff LC |
659 | (define (process-command command args opts) |
660 | "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its | |
661 | argument list and OPTS is the option alist." | |
662 | (case command | |
663 | ((list-generations) | |
664 | ;; List generations. No need to connect to the daemon, etc. | |
665 | (let ((pattern (match args | |
666 | (() "") | |
667 | ((pattern) pattern) | |
668 | (x (leave (_ "wrong number of arguments~%")))))) | |
669 | (list-generations pattern))) | |
670 | (else | |
671 | (process-action command args opts)))) | |
672 | ||
523e4896 | 673 | (define (guix-system . args) |
b3f21389 LC |
674 | (define (parse-sub-command arg result) |
675 | ;; Parse sub-command ARG and augment RESULT accordingly. | |
676 | (if (assoc-ref result 'action) | |
677 | (alist-cons 'argument arg result) | |
678 | (let ((action (string->symbol arg))) | |
679 | (case action | |
1c8a81b1 | 680 | ((build container vm vm-image disk-image reconfigure init |
65797bff | 681 | extension-graph dmd-graph list-generations) |
b3f21389 LC |
682 | (alist-cons 'action action result)) |
683 | (else (leave (_ "~a: unknown action~%") action)))))) | |
523e4896 | 684 | |
72b9d60d LC |
685 | (define (match-pair car) |
686 | ;; Return a procedure that matches a pair with CAR. | |
687 | (match-lambda | |
d6c3267a LC |
688 | ((head . tail) |
689 | (and (eq? car head) tail)) | |
690 | (_ #f))) | |
72b9d60d LC |
691 | |
692 | (define (option-arguments opts) | |
693 | ;; Extract the plain arguments from OPTS. | |
694 | (let* ((args (reverse (filter-map (match-pair 'argument) opts))) | |
695 | (count (length args)) | |
696 | (action (assoc-ref opts 'action))) | |
697 | (define (fail) | |
698 | (leave (_ "wrong number of arguments for action '~a'~%") | |
699 | action)) | |
700 | ||
d89e0990 LC |
701 | (unless action |
702 | (format (current-error-port) | |
703 | (_ "guix system: missing command name~%")) | |
704 | (format (current-error-port) | |
705 | (_ "Try 'guix system --help' for more information.~%")) | |
706 | (exit 1)) | |
707 | ||
72b9d60d | 708 | (case action |
1c8a81b1 | 709 | ((build container vm vm-image disk-image reconfigure) |
72b9d60d LC |
710 | (unless (= count 1) |
711 | (fail))) | |
712 | ((init) | |
713 | (unless (= count 2) | |
714 | (fail)))) | |
715 | args)) | |
716 | ||
523e4896 | 717 | (with-error-handling |
b3f21389 LC |
718 | (let* ((opts (parse-command-line args %options |
719 | (list %default-options) | |
720 | #:argument-handler | |
721 | parse-sub-command)) | |
c79d54fe | 722 | (args (option-arguments opts)) |
deaab8e3 | 723 | (command (assoc-ref opts 'action))) |
65797bff | 724 | (process-command command args opts)))) |
b25937e3 LC |
725 | |
726 | ;;; system.scm ends here |