Commit | Line | Data |
---|---|---|
523e4896 | 1 | ;;; GNU Guix --- Functional package management for GNU |
5ea69d9a | 2 | ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
b8300494 | 3 | ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> |
5ea69d9a | 4 | ;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com> |
a41134b4 | 5 | ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> |
523e4896 LC |
6 | ;;; |
7 | ;;; This file is part of GNU Guix. | |
8 | ;;; | |
9 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
10 | ;;; under the terms of the GNU General Public License as published by | |
11 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
12 | ;;; your option) any later version. | |
13 | ;;; | |
14 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;;; GNU General Public License for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public License | |
20 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | (define-module (guix scripts system) | |
b25937e3 | 23 | #:use-module (guix config) |
523e4896 LC |
24 | #:use-module (guix ui) |
25 | #:use-module (guix store) | |
7573d30f | 26 | #:use-module (guix grafts) |
72b9d60d | 27 | #:use-module (guix gexp) |
523e4896 LC |
28 | #:use-module (guix derivations) |
29 | #:use-module (guix packages) | |
30 | #:use-module (guix utils) | |
31 | #:use-module (guix monads) | |
5b516ef3 | 32 | #:use-module (guix records) |
b25937e3 | 33 | #:use-module (guix profiles) |
88981dd3 | 34 | #:use-module (guix scripts) |
523e4896 | 35 | #:use-module (guix scripts build) |
8fb58371 | 36 | #:use-module (guix graph) |
d6c3267a | 37 | #:use-module (guix scripts graph) |
72b9d60d | 38 | #:use-module (guix build utils) |
548f7a8f | 39 | #:use-module (gnu build install) |
7889394e | 40 | #:use-module (gnu system) |
9110c2e9 | 41 | #:use-module (gnu system file-systems) |
1c8a81b1 | 42 | #:use-module (gnu system linux-container) |
523e4896 | 43 | #:use-module (gnu system vm) |
c79d54fe | 44 | #:use-module (gnu system grub) |
d6c3267a | 45 | #:use-module (gnu services) |
0190c1c0 | 46 | #:use-module (gnu services shepherd) |
240b57f0 | 47 | #:use-module (gnu services herd) |
523e4896 | 48 | #:use-module (srfi srfi-1) |
240b57f0 | 49 | #:use-module (srfi srfi-11) |
906b1b09 | 50 | #:use-module (srfi srfi-19) |
72b9d60d | 51 | #:use-module (srfi srfi-26) |
65797bff LC |
52 | #:use-module (srfi srfi-34) |
53 | #:use-module (srfi srfi-35) | |
523e4896 LC |
54 | #:use-module (srfi srfi-37) |
55 | #:use-module (ice-9 match) | |
c52bf877 | 56 | #:use-module (rnrs bytevectors) |
731b9962 LC |
57 | #:export (guix-system |
58 | read-operating-system)) | |
523e4896 | 59 | |
8e42796b LC |
60 | \f |
61 | ;;; | |
62 | ;;; Operating system declaration. | |
63 | ;;; | |
64 | ||
523e4896 LC |
65 | (define %user-module |
66 | ;; Module in which the machine description file is loaded. | |
7ea1432e DT |
67 | (make-user-module '((gnu system) |
68 | (gnu services) | |
69 | (gnu system shadow)))) | |
523e4896 LC |
70 | |
71 | (define (read-operating-system file) | |
72 | "Read the operating-system declaration from FILE and return it." | |
7ea1432e | 73 | (load* file %user-module)) |
523e4896 | 74 | |
523e4896 | 75 | |
8e42796b LC |
76 | \f |
77 | ;;; | |
78 | ;;; Installation. | |
79 | ;;; | |
80 | ||
475e2ce2 DM |
81 | (define-syntax-rule (save-load-path-excursion body ...) |
82 | "Save the current values of '%load-path' and '%load-compiled-path', run | |
83 | BODY..., and restore them." | |
84 | (let ((path %load-path) | |
85 | (cpath %load-compiled-path)) | |
86 | (dynamic-wind | |
87 | (const #t) | |
88 | (lambda () | |
89 | body ...) | |
90 | (lambda () | |
91 | (set! %load-path path) | |
92 | (set! %load-compiled-path cpath))))) | |
93 | ||
94 | (define-syntax-rule (save-environment-excursion body ...) | |
95 | "Save the current environment variables, run BODY..., and restore them." | |
96 | (let ((env (environ))) | |
97 | (dynamic-wind | |
98 | (const #t) | |
99 | (lambda () | |
100 | body ...) | |
101 | (lambda () | |
102 | (environ env))))) | |
103 | ||
8e42796b LC |
104 | (define topologically-sorted* |
105 | (store-lift topologically-sorted)) | |
8e42796b LC |
106 | |
107 | ||
8334cf5b LC |
108 | (define* (copy-item item target |
109 | #:key (log-port (current-error-port))) | |
c56d19fb | 110 | "Copy ITEM to the store under root directory TARGET and register it." |
8e42796b | 111 | (mlet* %store-monad ((refs (references* item))) |
a52127c0 LC |
112 | (let ((dest (string-append target item)) |
113 | (state (string-append target "/var/guix"))) | |
8e42796b | 114 | (format log-port "copying '~a'...~%" item) |
78acff7c LC |
115 | |
116 | ;; Remove DEST if it exists to make sure that (1) we do not fail badly | |
117 | ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and | |
118 | ;; (2) we end up with the right contents. | |
119 | (when (file-exists? dest) | |
120 | (delete-file-recursively dest)) | |
121 | ||
8e42796b LC |
122 | (copy-recursively item dest |
123 | #:log (%make-void-port "w")) | |
124 | ||
125 | ;; Register ITEM; as a side-effect, it resets timestamps, etc. | |
a52127c0 LC |
126 | ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid |
127 | ;; reproducing the user's current settings; see | |
128 | ;; <http://bugs.gnu.org/18049>. | |
8e42796b LC |
129 | (unless (register-path item |
130 | #:prefix target | |
a52127c0 | 131 | #:state-directory state |
8e42796b LC |
132 | #:references refs) |
133 | (leave (_ "failed to register '~a' under '~a'~%") | |
134 | item target)) | |
135 | ||
136 | (return #t)))) | |
137 | ||
8334cf5b LC |
138 | (define* (copy-closure item target |
139 | #:key (log-port (current-error-port))) | |
140 | "Copy ITEM and all its dependencies to the store under root directory | |
141 | TARGET, and register them." | |
142 | (mlet* %store-monad ((refs (references* item)) | |
143 | (to-copy (topologically-sorted* | |
144 | (delete-duplicates (cons item refs) | |
145 | string=?)))) | |
146 | (sequence %store-monad | |
147 | (map (cut copy-item <> target #:log-port log-port) | |
148 | to-copy)))) | |
149 | ||
c3e79cde LC |
150 | (define (install-grub* grub.cfg device target) |
151 | "This is a variant of 'install-grub' with error handling, lifted in | |
152 | %STORE-MONAD" | |
16210486 LC |
153 | (let* ((gc-root (string-append target %gc-roots-directory |
154 | "/grub.cfg")) | |
6412e58a LC |
155 | (temp-gc-root (string-append gc-root ".new")) |
156 | (delete-file (lift1 delete-file %store-monad)) | |
157 | (make-symlink (lift2 switch-symlinks %store-monad)) | |
158 | (rename (lift2 rename-file %store-monad))) | |
39d1f82b | 159 | (mbegin %store-monad |
6412e58a LC |
160 | ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when |
161 | ;; 'install-grub' completes (being a bit paranoid.) | |
162 | (make-symlink temp-gc-root grub.cfg) | |
163 | ||
39d1f82b | 164 | (munless (false-if-exception (install-grub grub.cfg device target)) |
6412e58a | 165 | (delete-file temp-gc-root) |
39d1f82b LC |
166 | (leave (_ "failed to install GRUB on device '~a'~%") device)) |
167 | ||
168 | ;; Register GRUB.CFG as a GC root so that its dependencies (background | |
169 | ;; image, font, etc.) are not reclaimed. | |
6412e58a | 170 | (rename temp-gc-root gc-root)))) |
c3e79cde | 171 | |
8e42796b | 172 | (define* (install os-drv target |
c79d54fe LC |
173 | #:key (log-port (current-output-port)) |
174 | grub? grub.cfg device) | |
f245b03d LC |
175 | "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to |
176 | directory TARGET. TARGET must be an absolute directory name since that's what | |
177 | 'guix-register' expects. | |
c79d54fe LC |
178 | |
179 | When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." | |
8e42796b LC |
180 | (define (maybe-copy to-copy) |
181 | (with-monad %store-monad | |
182 | (if (string=? target "/") | |
183 | (begin | |
184 | (warning (_ "initializing the current root file system~%")) | |
185 | (return #t)) | |
186 | (begin | |
187 | ;; Make sure the target store exists. | |
188 | (mkdir-p (string-append target (%store-prefix))) | |
189 | ||
190 | ;; Copy items to the new store. | |
8334cf5b | 191 | (copy-closure to-copy target #:log-port log-port))))) |
8e42796b | 192 | |
4a35a866 LC |
193 | ;; Make sure TARGET is root-owned when running as root, but still allow |
194 | ;; non-root uses (useful for testing.) See | |
195 | ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>. | |
196 | (if (zero? (geteuid)) | |
197 | (chown target 0 0) | |
198 | (warning (_ "not running as 'root', so \ | |
199 | the ownership of '~a' may be incorrect!~%") | |
200 | target)) | |
201 | ||
202 | (chmod target #o755) | |
cc7fa592 | 203 | (let ((os-dir (derivation->output-path os-drv)) |
c9e46f1c LC |
204 | (format (lift format %store-monad)) |
205 | (populate (lift2 populate-root-file-system %store-monad))) | |
cc7fa592 LC |
206 | |
207 | (mbegin %store-monad | |
f245b03d LC |
208 | ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's |
209 | ;; background image and so on. | |
210 | (maybe-copy grub.cfg) | |
cc7fa592 LC |
211 | |
212 | ;; Create a bunch of additional files. | |
213 | (format log-port "populating '~a'...~%" target) | |
214 | (populate os-dir target) | |
215 | ||
c3e79cde LC |
216 | (mwhen grub? |
217 | (install-grub* grub.cfg device target))))) | |
72b9d60d | 218 | |
523e4896 | 219 | \f |
b25937e3 LC |
220 | ;;; |
221 | ;;; Reconfiguration. | |
222 | ;;; | |
223 | ||
224 | (define %system-profile | |
225 | ;; The system profile. | |
226 | (string-append %state-directory "/profiles/system")) | |
227 | ||
aa1e73a9 LC |
228 | (define-syntax-rule (with-shepherd-error-handling mbody ...) |
229 | "Catch and report Shepherd errors that arise when binding MBODY, a monadic | |
230 | expression in %STORE-MONAD." | |
231 | (lambda (store) | |
af0ba938 LC |
232 | (catch 'system-error |
233 | (lambda () | |
234 | (guard (c ((shepherd-error? c) | |
235 | (values (report-shepherd-error c) store))) | |
236 | (values (run-with-store store (begin mbody ...)) | |
237 | store))) | |
238 | (lambda (key proc format-string format-args errno . rest) | |
239 | (warning (_ "while talking to shepherd: ~a~%") | |
240 | (apply format #f format-string format-args)) | |
241 | (values #f store))))) | |
8bf92e39 LC |
242 | |
243 | (define (report-shepherd-error error) | |
244 | "Report ERROR, a '&shepherd-error' error condition object." | |
245 | (cond ((service-not-found-error? error) | |
246 | (report-error (_ "service '~a' could not be found~%") | |
247 | (service-not-found-error-service error))) | |
248 | ((action-not-found-error? error) | |
249 | (report-error (_ "service '~a' does not have an action '~a'~%") | |
250 | (action-not-found-error-service error) | |
251 | (action-not-found-error-action error))) | |
252 | ((action-exception-error? error) | |
253 | (report-error (_ "exception caught while executing '~a' \ | |
254 | on service '~a':~%") | |
255 | (action-exception-error-action error) | |
256 | (action-exception-error-service error)) | |
257 | (print-exception (current-error-port) #f | |
258 | (action-exception-error-key error) | |
259 | (action-exception-error-arguments error))) | |
260 | ((unknown-shepherd-error? error) | |
261 | (report-error (_ "something went wrong: ~s~%") | |
262 | (unknown-shepherd-error-sexp error))) | |
263 | ((shepherd-error? error) | |
264 | (report-error (_ "shepherd error~%"))) | |
265 | ((not error) ;not an error | |
266 | #t))) | |
267 | ||
b8692e46 LC |
268 | (define (call-with-service-upgrade-info new-services mproc) |
269 | "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of | |
270 | names of services to load (upgrade), and the list of names of services to | |
271 | unload." | |
183605c8 LC |
272 | (match (current-services) |
273 | ((services ...) | |
b8692e46 | 274 | (let-values (((to-unload to-load) |
7b44cae5 | 275 | (shepherd-service-upgrade services new-services))) |
f20a7b86 LC |
276 | (mproc to-load |
277 | (map (compose first live-service-provision) | |
278 | to-unload)))) | |
183605c8 LC |
279 | (#f |
280 | (with-monad %store-monad | |
281 | (warning (_ "failed to obtain list of shepherd services~%")) | |
282 | (return #f))))) | |
8bf92e39 | 283 | |
240b57f0 LC |
284 | (define (upgrade-shepherd-services os) |
285 | "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new | |
286 | services specified in OS and not currently running. | |
287 | ||
288 | This is currently very conservative in that it does not stop or unload any | |
289 | running service. Unloading or stopping the wrong service ('udev', say) could | |
290 | bring the system down." | |
240b57f0 | 291 | (define new-services |
efe7d19a | 292 | (service-value |
240b57f0 LC |
293 | (fold-services (operating-system-services os) |
294 | #:target-type shepherd-root-service-type))) | |
295 | ||
8bf92e39 LC |
296 | ;; Arrange to simply emit a warning if the service upgrade fails. |
297 | (with-shepherd-error-handling | |
298 | (call-with-service-upgrade-info new-services | |
299 | (lambda (to-load to-unload) | |
300 | (for-each (lambda (unload) | |
301 | (info (_ "unloading service '~a'...~%") unload) | |
302 | (unload-service unload)) | |
303 | to-unload) | |
304 | ||
305 | (with-monad %store-monad | |
306 | (munless (null? to-load) | |
307 | (let ((to-load-names (map shepherd-service-canonical-name to-load)) | |
308 | (to-start (filter shepherd-service-auto-start? to-load))) | |
309 | (info (_ "loading new services:~{ ~a~}...~%") to-load-names) | |
310 | (mlet %store-monad ((files (mapm %store-monad shepherd-service-file | |
311 | to-load))) | |
312 | ;; Here we assume that FILES are exactly those that were computed | |
313 | ;; as part of the derivation that built OS, which is normally the | |
314 | ;; case. | |
315 | (load-services (map derivation->output-path files)) | |
316 | ||
317 | (for-each start-service | |
318 | (map shepherd-service-canonical-name to-start)) | |
319 | (return #t))))))))) | |
240b57f0 | 320 | |
8e42796b LC |
321 | (define* (switch-to-system os |
322 | #:optional (profile %system-profile)) | |
323 | "Make a new generation of PROFILE pointing to the directory of OS, switch to | |
324 | it atomically, and then run OS's activation script." | |
325 | (mlet* %store-monad ((drv (operating-system-derivation os)) | |
326 | (script (operating-system-activation-script os))) | |
327 | (let* ((system (derivation->output-path drv)) | |
328 | (number (+ 1 (generation-number profile))) | |
329 | (generation (generation-file-name profile number))) | |
067a2e2d | 330 | (switch-symlinks generation system) |
8e42796b LC |
331 | (switch-symlinks profile generation) |
332 | ||
333 | (format #t (_ "activating system...~%")) | |
720ee245 LC |
334 | |
335 | ;; The activation script may change $PATH, among others, so protect | |
336 | ;; against that. | |
240b57f0 LC |
337 | (save-environment-excursion |
338 | ;; Tell 'activate-current-system' what the new system is. | |
339 | (setenv "GUIX_NEW_SYSTEM" system) | |
6d49355d | 340 | |
cfd50320 LC |
341 | ;; The activation script may modify '%load-path' & co., so protect |
342 | ;; against that. This is necessary to ensure that | |
343 | ;; 'upgrade-shepherd-services' gets to see the right modules when it | |
66a35ceb | 344 | ;; computes derivations with 'gexp->derivation'. |
cfd50320 LC |
345 | (save-load-path-excursion |
346 | (primitive-load (derivation->output-path script)))) | |
8e42796b | 347 | |
240b57f0 LC |
348 | ;; Finally, try to update system services. |
349 | (upgrade-shepherd-services os)))) | |
b25937e3 LC |
350 | |
351 | (define-syntax-rule (unless-file-not-found exp) | |
352 | (catch 'system-error | |
353 | (lambda () | |
354 | exp) | |
355 | (lambda args | |
356 | (if (= ENOENT (system-error-errno args)) | |
357 | #f | |
358 | (apply throw args))))) | |
359 | ||
906b1b09 LC |
360 | (define (seconds->string seconds) |
361 | "Return a string representing the date for SECONDS." | |
362 | (let ((time (make-time time-utc 0 seconds))) | |
363 | (date->string (time-utc->date time) | |
364 | "~Y-~m-~d ~H:~M"))) | |
365 | ||
abae042e DM |
366 | (define* (profile-boot-parameters #:optional (profile %system-profile) |
367 | (numbers (generation-numbers profile))) | |
368 | "Return a list of 'menu-entry' for the generations of PROFILE specified by | |
369 | NUMBERS, which is a list of generation numbers." | |
370 | (define (system->boot-parameters system number time) | |
371 | (unless-file-not-found | |
372 | (let* ((file (string-append system "/parameters")) | |
373 | (params (call-with-input-file file | |
374 | read-boot-parameters))) | |
375 | params))) | |
376 | (let* ((systems (map (cut generation-file-name profile <>) | |
377 | numbers)) | |
378 | (times (map (lambda (system) | |
379 | (unless-file-not-found | |
380 | (stat:mtime (lstat system)))) | |
381 | systems))) | |
382 | (filter-map system->boot-parameters systems numbers times))) | |
383 | ||
aff7280a CM |
384 | (define* (profile-grub-entries #:optional (profile %system-profile) |
385 | (numbers (generation-numbers profile))) | |
386 | "Return a list of 'menu-entry' for the generations of PROFILE specified by | |
387 | NUMBERS, which is a list of generation numbers." | |
906b1b09 | 388 | (define (system->grub-entry system number time) |
b25937e3 | 389 | (unless-file-not-found |
b8300494 AK |
390 | (let* ((file (string-append system "/parameters")) |
391 | (params (call-with-input-file file | |
392 | read-boot-parameters)) | |
393 | (label (boot-parameters-label params)) | |
394 | (root (boot-parameters-root-device params)) | |
c52bf877 MW |
395 | (root-device (if (bytevector? root) |
396 | (uuid->string root) | |
397 | root)) | |
b8300494 | 398 | (kernel (boot-parameters-kernel params)) |
0f65f54e CSLL |
399 | (kernel-arguments (boot-parameters-kernel-arguments params)) |
400 | (initrd (boot-parameters-initrd params))) | |
b8300494 AK |
401 | (menu-entry |
402 | (label (string-append label " (#" | |
403 | (number->string number) ", " | |
404 | (seconds->string time) ")")) | |
1ef8b72a CM |
405 | (device (boot-parameters-store-device params)) |
406 | (device-mount-point (boot-parameters-store-mount-point params)) | |
b8300494 AK |
407 | (linux kernel) |
408 | (linux-arguments | |
c52bf877 | 409 | (cons* (string-append "--root=" root-device) |
0f65f54e CSLL |
410 | (string-append "--system=" system) |
411 | (string-append "--load=" system "/boot") | |
b8300494 | 412 | kernel-arguments)) |
0f65f54e | 413 | (initrd initrd))))) |
b25937e3 | 414 | |
aff7280a | 415 | (let* ((systems (map (cut generation-file-name profile <>) |
906b1b09 LC |
416 | numbers)) |
417 | (times (map (lambda (system) | |
418 | (unless-file-not-found | |
419 | (stat:mtime (lstat system)))) | |
420 | systems))) | |
421 | (filter-map system->grub-entry systems numbers times))) | |
b25937e3 LC |
422 | |
423 | \f | |
8074b330 CM |
424 | ;;; |
425 | ;;; Roll-back. | |
426 | ;;; | |
427 | (define (roll-back-system store) | |
428 | "Roll back the system profile to its previous generation. STORE is an open | |
429 | connection to the store." | |
430 | (switch-to-system-generation store "-1")) | |
431 | \f | |
432 | ;;; | |
433 | ;;; Switch generations. | |
434 | ;;; | |
435 | (define (switch-to-system-generation store spec) | |
436 | "Switch the system profile to the generation specified by SPEC, and | |
437 | re-install grub with a grub configuration file that uses the specified system | |
438 | generation as its default entry. STORE is an open connection to the store." | |
439 | (let ((number (relative-generation-spec->number %system-profile spec))) | |
440 | (if number | |
441 | (begin | |
442 | (reinstall-grub store number) | |
443 | (switch-to-generation* %system-profile number)) | |
444 | (leave (_ "cannot switch to system generation '~a'~%") spec)))) | |
445 | ||
446 | (define (reinstall-grub store number) | |
447 | "Re-install grub for existing system profile generation NUMBER. STORE is an | |
448 | open connection to the store." | |
449 | (let* ((generation (generation-file-name %system-profile number)) | |
450 | (file (string-append generation "/parameters")) | |
451 | (params (unless-file-not-found | |
452 | (call-with-input-file file read-boot-parameters))) | |
453 | (root-device (boot-parameters-root-device params)) | |
454 | ;; We don't currently keep track of past menu entries' details. The | |
455 | ;; default values will allow the system to boot, even if they differ | |
456 | ;; from the actual past values for this generation's entry. | |
457 | (grub-config (grub-configuration (device root-device))) | |
458 | ;; Make the specified system generation the default entry. | |
958a1fda | 459 | (entries (profile-grub-entries %system-profile (list number))) |
8074b330 | 460 | (old-generations (delv number (generation-numbers %system-profile))) |
958a1fda | 461 | (old-entries (profile-grub-entries %system-profile old-generations)) |
8074b330 CM |
462 | (grub.cfg (run-with-store store |
463 | (grub-configuration-file grub-config | |
464 | entries | |
465 | #:old-entries old-entries)))) | |
466 | (show-what-to-build store (list grub.cfg)) | |
467 | (build-derivations store (list grub.cfg)) | |
468 | ;; This is basically the same as install-grub*, but for now we avoid | |
469 | ;; re-installing the GRUB boot loader itself onto a device, mainly because | |
470 | ;; we don't in general have access to the same version of the GRUB package | |
471 | ;; which was used when installing this other system generation. | |
472 | (let* ((grub.cfg-path (derivation->output-path grub.cfg)) | |
473 | (gc-root (string-append %gc-roots-directory "/grub.cfg")) | |
474 | (temp-gc-root (string-append gc-root ".new"))) | |
475 | (switch-symlinks temp-gc-root grub.cfg-path) | |
476 | (unless (false-if-exception (install-grub-config grub.cfg-path "/")) | |
477 | (delete-file temp-gc-root) | |
478 | (leave (_ "failed to re-install GRUB configuration file: '~a'~%") | |
479 | grub.cfg-path)) | |
480 | (rename-file temp-gc-root gc-root)))) | |
481 | ||
482 | \f | |
d6c3267a | 483 | ;;; |
6f305ea5 | 484 | ;;; Graphs. |
d6c3267a LC |
485 | ;;; |
486 | ||
487 | (define (service-node-label service) | |
488 | "Return a label to represent SERVICE." | |
489 | (let ((type (service-kind service)) | |
efe7d19a | 490 | (value (service-value service))) |
d6c3267a LC |
491 | (string-append (symbol->string (service-type-name type)) |
492 | (cond ((or (number? value) (symbol? value)) | |
493 | (string-append " " (object->string value))) | |
494 | ((string? value) | |
495 | (string-append " " value)) | |
496 | ((file-system? value) | |
497 | (string-append " " (file-system-mount-point value))) | |
498 | (else | |
499 | ""))))) | |
500 | ||
501 | (define (service-node-type services) | |
502 | "Return a node type for SERVICES. Since <service> instances are not | |
503 | self-contained (they express dependencies on service types, not on services), | |
504 | we have to create the 'edges' procedure dynamically as a function of the full | |
505 | list of services." | |
506 | (node-type | |
507 | (name "service") | |
508 | (description "the DAG of services") | |
509 | (identifier (lift1 object-address %store-monad)) | |
510 | (label service-node-label) | |
511 | (edges (lift1 (service-back-edges services) %store-monad)))) | |
512 | ||
710fa231 | 513 | (define (shepherd-service-node-label service) |
d4053c71 AK |
514 | "Return a label for a node representing a <shepherd-service>." |
515 | (string-join (map symbol->string (shepherd-service-provision service)))) | |
6f305ea5 | 516 | |
710fa231 | 517 | (define (shepherd-service-node-type services) |
d4053c71 | 518 | "Return a node type for SERVICES, a list of <shepherd-service>." |
6f305ea5 | 519 | (node-type |
710fa231 AK |
520 | (name "shepherd-service") |
521 | (description "the dependency graph of shepherd services") | |
522 | (identifier (lift1 shepherd-service-node-label %store-monad)) | |
523 | (label shepherd-service-node-label) | |
d4053c71 | 524 | (edges (lift1 (shepherd-service-back-edges services) %store-monad)))) |
d6c3267a LC |
525 | |
526 | \f | |
65797bff LC |
527 | ;;; |
528 | ;;; Generations. | |
529 | ;;; | |
530 | ||
531 | (define* (display-system-generation number | |
532 | #:optional (profile %system-profile)) | |
533 | "Display a summary of system generation NUMBER in a human-readable format." | |
534 | (unless (zero? number) | |
c52bf877 MW |
535 | (let* ((generation (generation-file-name profile number)) |
536 | (param-file (string-append generation "/parameters")) | |
537 | (params (call-with-input-file param-file read-boot-parameters)) | |
538 | (label (boot-parameters-label params)) | |
539 | (root (boot-parameters-root-device params)) | |
540 | (root-device (if (bytevector? root) | |
541 | (uuid->string root) | |
542 | root)) | |
543 | (kernel (boot-parameters-kernel params))) | |
65797bff LC |
544 | (display-generation profile number) |
545 | (format #t (_ " file name: ~a~%") generation) | |
546 | (format #t (_ " canonical file name: ~a~%") (readlink* generation)) | |
b8300494 AK |
547 | ;; TRANSLATORS: Please preserve the two-space indentation. |
548 | (format #t (_ " label: ~a~%") label) | |
c52bf877 | 549 | (format #t (_ " root device: ~a~%") root-device) |
b8300494 | 550 | (format #t (_ " kernel: ~a~%") kernel)))) |
65797bff LC |
551 | |
552 | (define* (list-generations pattern #:optional (profile %system-profile)) | |
553 | "Display in a human-readable format all the system generations matching | |
554 | PATTERN, a string. When PATTERN is #f, display all the system generations." | |
555 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
556 | (raise (condition (&profile-not-found-error | |
557 | (profile profile))))) | |
558 | ((string-null? pattern) | |
559 | (for-each display-system-generation (profile-generations profile))) | |
560 | ((matching-generations pattern profile) | |
561 | => | |
562 | (lambda (numbers) | |
563 | (if (null-list? numbers) | |
564 | (exit 1) | |
565 | (leave-on-EPIPE | |
566 | (for-each display-system-generation numbers))))) | |
567 | (else | |
568 | (leave (_ "invalid syntax: ~a~%") pattern)))) | |
569 | ||
570 | \f | |
8e42796b LC |
571 | ;;; |
572 | ;;; Action. | |
573 | ;;; | |
574 | ||
575 | (define* (system-derivation-for-action os action | |
0276f697 | 576 | #:key image-size full-boot? mappings) |
8e42796b LC |
577 | "Return as a monadic value the derivation for OS according to ACTION." |
578 | (case action | |
579 | ((build init reconfigure) | |
580 | (operating-system-derivation os)) | |
1c8a81b1 DT |
581 | ((container) |
582 | (container-script os #:mappings mappings)) | |
8e42796b LC |
583 | ((vm-image) |
584 | (system-qemu-image os #:disk-image-size image-size)) | |
585 | ((vm) | |
6aa260af LC |
586 | (system-qemu-image/shared-store-script os |
587 | #:full-boot? full-boot? | |
4c0416ae LC |
588 | #:disk-image-size |
589 | (if full-boot? | |
590 | image-size | |
591 | (* 30 (expt 2 20))) | |
0276f697 | 592 | #:mappings mappings)) |
8e42796b LC |
593 | ((disk-image) |
594 | (system-disk-image os #:disk-image-size image-size)))) | |
595 | ||
7f949db0 LC |
596 | (define (maybe-suggest-running-guix-pull) |
597 | "Suggest running 'guix pull' if this has never been done before." | |
598 | ;; The reason for this is that the 'guix' binding that we see here comes | |
599 | ;; from either ~/.config/latest or, if it's missing, from the | |
600 | ;; globally-installed Guix, which is necessarily older. See | |
601 | ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for | |
602 | ;; a discussion. | |
603 | (define latest | |
604 | (string-append (config-directory) "/latest")) | |
605 | ||
606 | (unless (file-exists? latest) | |
607 | (warning (_ "~a not found: 'guix pull' was never run~%") latest) | |
608 | (warning (_ "Consider running 'guix pull' before 'reconfigure'.~%")) | |
609 | (warning (_ "Failing to do that may downgrade your system!~%")))) | |
610 | ||
8e42796b | 611 | (define* (perform-action action os |
e61519ab | 612 | #:key bootloader? dry-run? derivations-only? |
8e42796b | 613 | use-substitutes? device target |
0276f697 | 614 | image-size full-boot? |
5ea69d9a CM |
615 | (mappings '()) |
616 | (gc-root #f)) | |
8e42796b LC |
617 | "Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is |
618 | the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE | |
619 | is the size of the image to be built, for the 'vm-image' and 'disk-image' | |
ab11f0be | 620 | actions. FULL-BOOT? is used for the 'vm' action; it determines whether to |
f3f427c2 LC |
621 | boot directly to the kernel or to the bootloader. |
622 | ||
623 | When DERIVATIONS-ONLY? is true, print the derivation file name(s) without | |
5ea69d9a CM |
624 | building anything. |
625 | ||
626 | When GC-ROOT is a path, also make that path an indirect root of the build | |
627 | output when building a system derivation, such as a disk image." | |
f3f427c2 LC |
628 | (define println |
629 | (cut format #t "~a~%" <>)) | |
630 | ||
7f949db0 LC |
631 | (when (eq? action 'reconfigure) |
632 | (maybe-suggest-running-guix-pull)) | |
633 | ||
8e42796b LC |
634 | (mlet* %store-monad |
635 | ((sys (system-derivation-for-action os action | |
ab11f0be | 636 | #:image-size image-size |
0276f697 LC |
637 | #:full-boot? full-boot? |
638 | #:mappings mappings)) | |
81bf2ccb MB |
639 | (grub (package->derivation (grub-configuration-grub |
640 | (operating-system-bootloader os)))) | |
1c8a81b1 DT |
641 | (grub.cfg (if (eq? 'container action) |
642 | (return #f) | |
c76b3046 MO |
643 | (operating-system-bootcfg os |
644 | (if (eq? 'init action) | |
645 | '() | |
958a1fda | 646 | (profile-grub-entries))))) |
a7043618 LC |
647 | |
648 | ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if | |
649 | ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC | |
650 | ;; root. See <http://bugs.gnu.org/21068>. | |
651 | (drvs -> (if (memq action '(init reconfigure)) | |
e61519ab | 652 | (if bootloader? |
a7043618 LC |
653 | (list sys grub.cfg grub) |
654 | (list sys grub.cfg)) | |
8e42796b | 655 | (list sys))) |
f3f427c2 LC |
656 | (% (if derivations-only? |
657 | (return (for-each (compose println derivation-file-name) | |
658 | drvs)) | |
659 | (maybe-build drvs #:dry-run? dry-run? | |
660 | #:use-substitutes? use-substitutes?)))) | |
8e42796b | 661 | |
f3f427c2 | 662 | (if (or dry-run? derivations-only?) |
8e42796b LC |
663 | (return #f) |
664 | (begin | |
f3f427c2 LC |
665 | (for-each (compose println derivation->output-path) |
666 | drvs) | |
8e42796b LC |
667 | |
668 | ;; Make sure GRUB is accessible. | |
e61519ab | 669 | (when bootloader? |
8e42796b LC |
670 | (let ((prefix (derivation->output-path grub))) |
671 | (setenv "PATH" | |
672 | (string-append prefix "/bin:" prefix "/sbin:" | |
673 | (getenv "PATH"))))) | |
674 | ||
675 | (case action | |
676 | ((reconfigure) | |
c3e79cde LC |
677 | (mbegin %store-monad |
678 | (switch-to-system os) | |
e61519ab | 679 | (mwhen bootloader? |
c3e79cde LC |
680 | (install-grub* (derivation->output-path grub.cfg) |
681 | device "/")))) | |
8e42796b LC |
682 | ((init) |
683 | (newline) | |
684 | (format #t (_ "initializing operating system under '~a'...~%") | |
685 | target) | |
686 | (install sys (canonicalize-path target) | |
e61519ab | 687 | #:grub? bootloader? |
8e42796b LC |
688 | #:grub.cfg (derivation->output-path grub.cfg) |
689 | #:device device)) | |
690 | (else | |
5ea69d9a CM |
691 | ;; All we had to do was to build SYS and maybe register an |
692 | ;; indirect GC root. | |
693 | (let ((output (derivation->output-path sys))) | |
694 | (mbegin %store-monad | |
695 | (mwhen gc-root | |
696 | (register-root* (list output) gc-root)) | |
697 | (return output))))))))) | |
8e42796b | 698 | |
d6c3267a LC |
699 | (define (export-extension-graph os port) |
700 | "Export the service extension graph of OS to PORT." | |
701 | (let* ((services (operating-system-services os)) | |
d62e201c LC |
702 | (system (find (lambda (service) |
703 | (eq? (service-kind service) system-service-type)) | |
d6c3267a | 704 | services))) |
d62e201c | 705 | (export-graph (list system) (current-output-port) |
d6c3267a LC |
706 | #:node-type (service-node-type services) |
707 | #:reverse-edges? #t))) | |
708 | ||
710fa231 | 709 | (define (export-shepherd-graph os port) |
d4053c71 AK |
710 | "Export the graph of shepherd services of OS to PORT." |
711 | (let* ((services (operating-system-services os)) | |
712 | (pid1 (fold-services services | |
713 | #:target-type shepherd-root-service-type)) | |
efe7d19a | 714 | (shepherds (service-value pid1)) ;list of <shepherd-service> |
d4053c71 AK |
715 | (sinks (filter (lambda (service) |
716 | (null? (shepherd-service-requirement service))) | |
717 | shepherds))) | |
6f305ea5 | 718 | (export-graph sinks (current-output-port) |
710fa231 | 719 | #:node-type (shepherd-service-node-type shepherds) |
6f305ea5 LC |
720 | #:reverse-edges? #t))) |
721 | ||
8e42796b | 722 | \f |
523e4896 LC |
723 | ;;; |
724 | ;;; Options. | |
725 | ;;; | |
726 | ||
727 | (define (show-help) | |
8074b330 CM |
728 | (display (_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE] |
729 | Build the operating system declared in FILE according to ACTION. | |
730 | Some ACTIONS support additional ARGS.\n")) | |
7889394e LC |
731 | (newline) |
732 | (display (_ "The valid values for ACTION are:\n")) | |
2a4e2e4b | 733 | (newline) |
7889394e | 734 | (display (_ "\ |
2a4e2e4b | 735 | reconfigure switch to a new operating system configuration\n")) |
8074b330 CM |
736 | (display (_ "\ |
737 | roll-back switch to the previous operating system configuration\n")) | |
738 | (display (_ "\ | |
739 | switch-generation switch to an existing operating system configuration\n")) | |
65797bff LC |
740 | (display (_ "\ |
741 | list-generations list the system generations\n")) | |
b25937e3 | 742 | (display (_ "\ |
2a4e2e4b | 743 | build build the operating system without installing anything\n")) |
1c8a81b1 | 744 | (display (_ "\ |
fbd213a8 | 745 | container build a container that shares the host's store\n")) |
7889394e | 746 | (display (_ "\ |
2a4e2e4b | 747 | vm build a virtual machine image that shares the host's store\n")) |
7889394e | 748 | (display (_ "\ |
2a4e2e4b | 749 | vm-image build a freestanding virtual machine image\n")) |
72b9d60d | 750 | (display (_ "\ |
2a4e2e4b | 751 | disk-image build a disk image, suitable for a USB stick\n")) |
fb729425 | 752 | (display (_ "\ |
d6c3267a LC |
753 | init initialize a root file system to run GNU\n")) |
754 | (display (_ "\ | |
755 | extension-graph emit the service extension graph in Dot format\n")) | |
6f305ea5 | 756 | (display (_ "\ |
710fa231 | 757 | shepherd-graph emit the graph of shepherd services in Dot format\n")) |
7889394e | 758 | |
523e4896 | 759 | (show-build-options-help) |
f3f427c2 LC |
760 | (display (_ " |
761 | -d, --derivation return the derivation of the given system")) | |
db030303 LC |
762 | (display (_ " |
763 | --on-error=STRATEGY | |
764 | apply STRATEGY when an error occurs while reading FILE")) | |
2e7b5cea LC |
765 | (display (_ " |
766 | --image-size=SIZE for 'vm-image', produce an image of SIZE")) | |
c79d54fe LC |
767 | (display (_ " |
768 | --no-grub for 'init', do not install GRUB")) | |
0276f697 LC |
769 | (display (_ " |
770 | --share=SPEC for 'vm', share host file system according to SPEC")) | |
5ea69d9a CM |
771 | (display (_ " |
772 | -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container', | |
773 | and 'build', make FILE a symlink to the result, and | |
774 | register it as a garbage collector root")) | |
0276f697 LC |
775 | (display (_ " |
776 | --expose=SPEC for 'vm', expose host file system according to SPEC")) | |
ab11f0be LC |
777 | (display (_ " |
778 | --full-boot for 'vm', make a full boot sequence")) | |
523e4896 LC |
779 | (newline) |
780 | (display (_ " | |
781 | -h, --help display this help and exit")) | |
782 | (display (_ " | |
783 | -V, --version display version information and exit")) | |
784 | (newline) | |
785 | (show-bug-report-information)) | |
786 | ||
787 | (define %options | |
788 | ;; Specifications of the command-line options. | |
789 | (cons* (option '(#\h "help") #f #f | |
790 | (lambda args | |
791 | (show-help) | |
792 | (exit 0))) | |
793 | (option '(#\V "version") #f #f | |
794 | (lambda args | |
795 | (show-version-and-exit "guix system"))) | |
f3f427c2 LC |
796 | (option '(#\d "derivation") #f #f |
797 | (lambda (opt name arg result) | |
798 | (alist-cons 'derivations-only? #t result))) | |
db030303 LC |
799 | (option '("on-error") #t #f |
800 | (lambda (opt name arg result) | |
801 | (alist-cons 'on-error (string->symbol arg) | |
802 | result))) | |
2e7b5cea LC |
803 | (option '("image-size") #t #f |
804 | (lambda (opt name arg result) | |
805 | (alist-cons 'image-size (size->number arg) | |
806 | result))) | |
c79d54fe LC |
807 | (option '("no-grub") #f #f |
808 | (lambda (opt name arg result) | |
e61519ab | 809 | (alist-cons 'install-bootloader? #f result))) |
ab11f0be LC |
810 | (option '("full-boot") #f #f |
811 | (lambda (opt name arg result) | |
812 | (alist-cons 'full-boot? #t result))) | |
0276f697 LC |
813 | |
814 | (option '("share") #t #f | |
815 | (lambda (opt name arg result) | |
816 | (alist-cons 'file-system-mapping | |
817 | (specification->file-system-mapping arg #t) | |
818 | result))) | |
819 | (option '("expose") #t #f | |
820 | (lambda (opt name arg result) | |
821 | (alist-cons 'file-system-mapping | |
822 | (specification->file-system-mapping arg #f) | |
823 | result))) | |
824 | ||
523e4896 LC |
825 | (option '(#\n "dry-run") #f #f |
826 | (lambda (opt name arg result) | |
fd59105c | 827 | (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) |
df2ce343 LC |
828 | (option '(#\s "system") #t #f |
829 | (lambda (opt name arg result) | |
830 | (alist-cons 'system arg | |
831 | (alist-delete 'system result eq?)))) | |
5ea69d9a CM |
832 | (option '(#\r "root") #t #f |
833 | (lambda (opt name arg result) | |
834 | (alist-cons 'gc-root arg result))) | |
523e4896 LC |
835 | %standard-build-options)) |
836 | ||
837 | (define %default-options | |
838 | ;; Alist of default option values. | |
839 | `((system . ,(%current-system)) | |
840 | (substitutes? . #t) | |
7573d30f | 841 | (graft? . #t) |
523e4896 LC |
842 | (build-hook? . #t) |
843 | (max-silent-time . 3600) | |
2e7b5cea | 844 | (verbosity . 0) |
c79d54fe | 845 | (image-size . ,(* 900 (expt 2 20))) |
e61519ab | 846 | (install-bootloader? . #t))) |
523e4896 LC |
847 | |
848 | \f | |
849 | ;;; | |
850 | ;;; Entry point. | |
851 | ;;; | |
852 | ||
deaab8e3 | 853 | (define (process-action action args opts) |
65797bff LC |
854 | "Process ACTION, a sub-command, with the arguments are listed in ARGS. |
855 | ACTION must be one of the sub-commands that takes an operating system | |
856 | declaration as an argument (a file name.) OPTS is the raw alist of options | |
857 | resulting from command-line parsing." | |
e61519ab MO |
858 | (let* ((file (match args |
859 | (() #f) | |
860 | ((x . _) x))) | |
861 | (system (assoc-ref opts 'system)) | |
862 | (os (if file | |
863 | (load* file %user-module | |
864 | #:on-error (assoc-ref opts 'on-error)) | |
865 | (leave (_ "no configuration file specified~%")))) | |
866 | ||
867 | (dry? (assoc-ref opts 'dry-run?)) | |
868 | (bootloader? (assoc-ref opts 'install-bootloader?)) | |
869 | (target (match args | |
870 | ((first second) second) | |
871 | (_ #f))) | |
872 | (device (and bootloader? | |
873 | (grub-configuration-device | |
874 | (operating-system-bootloader os))))) | |
deaab8e3 LC |
875 | |
876 | (with-store store | |
877 | (set-build-options-from-command-line store opts) | |
878 | ||
879 | (run-with-store store | |
880 | (mbegin %store-monad | |
881 | (set-guile-for-build (default-guile)) | |
882 | (case action | |
883 | ((extension-graph) | |
884 | (export-extension-graph os (current-output-port))) | |
710fa231 AK |
885 | ((shepherd-graph) |
886 | (export-shepherd-graph os (current-output-port))) | |
deaab8e3 LC |
887 | (else |
888 | (perform-action action os | |
889 | #:dry-run? dry? | |
890 | #:derivations-only? (assoc-ref opts | |
891 | 'derivations-only?) | |
892 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
893 | #:image-size (assoc-ref opts 'image-size) | |
894 | #:full-boot? (assoc-ref opts 'full-boot?) | |
895 | #:mappings (filter-map (match-lambda | |
896 | (('file-system-mapping . m) | |
897 | m) | |
898 | (_ #f)) | |
899 | opts) | |
e61519ab | 900 | #:bootloader? bootloader? |
5ea69d9a CM |
901 | #:target target #:device device |
902 | #:gc-root (assoc-ref opts 'gc-root))))) | |
deaab8e3 LC |
903 | #:system system)))) |
904 | ||
65797bff LC |
905 | (define (process-command command args opts) |
906 | "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its | |
907 | argument list and OPTS is the option alist." | |
908 | (case command | |
8074b330 CM |
909 | ;; The following commands do not need to use the store, and they do not need |
910 | ;; an operating system configuration file. | |
65797bff | 911 | ((list-generations) |
65797bff LC |
912 | (let ((pattern (match args |
913 | (() "") | |
914 | ((pattern) pattern) | |
915 | (x (leave (_ "wrong number of arguments~%")))))) | |
916 | (list-generations pattern))) | |
8074b330 CM |
917 | ;; The following commands need to use the store, but they do not need an |
918 | ;; operating system configuration file. | |
919 | ((switch-generation) | |
920 | (let ((pattern (match args | |
921 | ((pattern) pattern) | |
922 | (x (leave (_ "wrong number of arguments~%")))))) | |
923 | (with-store store | |
924 | (set-build-options-from-command-line store opts) | |
925 | (switch-to-system-generation store pattern)))) | |
926 | ((roll-back) | |
927 | (let ((pattern (match args | |
928 | (() "") | |
929 | (x (leave (_ "wrong number of arguments~%")))))) | |
930 | (with-store store | |
931 | (set-build-options-from-command-line store opts) | |
932 | (roll-back-system store)))) | |
933 | ;; The following commands need to use the store, and they also | |
934 | ;; need an operating system configuration file. | |
935 | (else (process-action command args opts)))) | |
65797bff | 936 | |
523e4896 | 937 | (define (guix-system . args) |
b3f21389 LC |
938 | (define (parse-sub-command arg result) |
939 | ;; Parse sub-command ARG and augment RESULT accordingly. | |
940 | (if (assoc-ref result 'action) | |
941 | (alist-cons 'argument arg result) | |
942 | (let ((action (string->symbol arg))) | |
943 | (case action | |
1c8a81b1 | 944 | ((build container vm vm-image disk-image reconfigure init |
8074b330 CM |
945 | extension-graph shepherd-graph list-generations roll-back |
946 | switch-generation) | |
b3f21389 LC |
947 | (alist-cons 'action action result)) |
948 | (else (leave (_ "~a: unknown action~%") action)))))) | |
523e4896 | 949 | |
72b9d60d LC |
950 | (define (match-pair car) |
951 | ;; Return a procedure that matches a pair with CAR. | |
952 | (match-lambda | |
d6c3267a LC |
953 | ((head . tail) |
954 | (and (eq? car head) tail)) | |
955 | (_ #f))) | |
72b9d60d LC |
956 | |
957 | (define (option-arguments opts) | |
958 | ;; Extract the plain arguments from OPTS. | |
959 | (let* ((args (reverse (filter-map (match-pair 'argument) opts))) | |
960 | (count (length args)) | |
961 | (action (assoc-ref opts 'action))) | |
962 | (define (fail) | |
963 | (leave (_ "wrong number of arguments for action '~a'~%") | |
964 | action)) | |
965 | ||
d89e0990 LC |
966 | (unless action |
967 | (format (current-error-port) | |
968 | (_ "guix system: missing command name~%")) | |
969 | (format (current-error-port) | |
970 | (_ "Try 'guix system --help' for more information.~%")) | |
971 | (exit 1)) | |
972 | ||
72b9d60d | 973 | (case action |
1c8a81b1 | 974 | ((build container vm vm-image disk-image reconfigure) |
72b9d60d LC |
975 | (unless (= count 1) |
976 | (fail))) | |
977 | ((init) | |
978 | (unless (= count 2) | |
979 | (fail)))) | |
980 | args)) | |
981 | ||
523e4896 | 982 | (with-error-handling |
b3f21389 LC |
983 | (let* ((opts (parse-command-line args %options |
984 | (list %default-options) | |
985 | #:argument-handler | |
986 | parse-sub-command)) | |
c79d54fe | 987 | (args (option-arguments opts)) |
deaab8e3 | 988 | (command (assoc-ref opts 'action))) |
7573d30f LC |
989 | (parameterize ((%graft? (assoc-ref opts 'graft?))) |
990 | (process-command command args opts))))) | |
b25937e3 | 991 | |
8bf92e39 LC |
992 | ;;; Local Variables: |
993 | ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1) | |
994 | ;;; End: | |
995 | ||
b25937e3 | 996 | ;;; system.scm ends here |