Commit | Line | Data |
---|---|---|
523e4896 | 1 | ;;; GNU Guix --- Functional package management for GNU |
9679123c | 2 | ;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> |
b8300494 | 3 | ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> |
a335f6fc | 4 | ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> |
fcc4c6ae | 5 | ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> |
945449b4 | 6 | ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> |
b33454ae | 7 | ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> |
7ca533c7 | 8 | ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> |
036f23f0 | 9 | ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> |
da09b47b | 10 | ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> |
236a8829 | 11 | ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> |
b8b56bad | 12 | ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> |
523e4896 LC |
13 | ;;; |
14 | ;;; This file is part of GNU Guix. | |
15 | ;;; | |
16 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
17 | ;;; under the terms of the GNU General Public License as published by | |
18 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
19 | ;;; your option) any later version. | |
20 | ;;; | |
21 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
22 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
23 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
24 | ;;; GNU General Public License for more details. | |
25 | ;;; | |
26 | ;;; You should have received a copy of the GNU General Public License | |
27 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
28 | ||
29 | (define-module (guix scripts system) | |
b25937e3 | 30 | #:use-module (guix config) |
523e4896 | 31 | #:use-module (guix ui) |
2637cfd7 | 32 | #:use-module ((guix status) #:select (with-status-verbosity)) |
523e4896 | 33 | #:use-module (guix store) |
1574bd82 LC |
34 | #:autoload (guix base16) (bytevector->base16-string) |
35 | #:autoload (guix store database) | |
36 | (sqlite-register store-database-file call-with-database) | |
cd6c5ddf | 37 | #:autoload (guix build store-copy) (copy-store-item) |
637db76d | 38 | #:use-module (guix describe) |
7573d30f | 39 | #:use-module (guix grafts) |
72b9d60d | 40 | #:use-module (guix gexp) |
523e4896 LC |
41 | #:use-module (guix derivations) |
42 | #:use-module (guix packages) | |
43 | #:use-module (guix utils) | |
44 | #:use-module (guix monads) | |
5b516ef3 | 45 | #:use-module (guix records) |
b25937e3 | 46 | #:use-module (guix profiles) |
88981dd3 | 47 | #:use-module (guix scripts) |
60f4564a | 48 | #:use-module (guix channels) |
523e4896 | 49 | #:use-module (guix scripts build) |
499b166d LC |
50 | #:autoload (guix scripts package) (delete-generations |
51 | delete-matching-generations) | |
60f4564a | 52 | #:autoload (guix scripts pull) (channel-commit-hyperlink) |
6c3690fc | 53 | #:autoload (guix graph) (export-graph node-type |
f5a94b3a | 54 | graph-backend-name lookup-backend) |
d6c3267a | 55 | #:use-module (guix scripts graph) |
5c8c8c45 | 56 | #:use-module (guix scripts system reconfigure) |
72b9d60d | 57 | #:use-module (guix build utils) |
e261e276 LC |
58 | #:use-module (guix progress) |
59 | #:use-module ((guix build syscalls) #:select (terminal-columns)) | |
c717f27c | 60 | #:use-module (gnu build image) |
548f7a8f | 61 | #:use-module (gnu build install) |
9d80d0e9 LC |
62 | #:autoload (gnu build file-systems) |
63 | (find-partition-by-label find-partition-by-uuid) | |
424cea80 LC |
64 | #:autoload (gnu build linux-modules) |
65 | (device-module-aliases matching-modules) | |
ca23693d | 66 | #:use-module (gnu system linux-initrd) |
f19cf27c | 67 | #:use-module (gnu image) |
d5073fd1 | 68 | #:use-module (gnu platform) |
7889394e | 69 | #:use-module (gnu system) |
b09a8da4 | 70 | #:use-module (gnu bootloader) |
9110c2e9 | 71 | #:use-module (gnu system file-systems) |
f19cf27c | 72 | #:use-module (gnu system image) |
893d0b0b | 73 | #:use-module (gnu system mapped-devices) |
1c8a81b1 | 74 | #:use-module (gnu system linux-container) |
fc2de6ce | 75 | #:use-module (gnu system uuid) |
523e4896 | 76 | #:use-module (gnu system vm) |
d6c3267a | 77 | #:use-module (gnu services) |
0190c1c0 | 78 | #:use-module (gnu services shepherd) |
240b57f0 | 79 | #:use-module (gnu services herd) |
523e4896 | 80 | #:use-module (srfi srfi-1) |
240b57f0 | 81 | #:use-module (srfi srfi-11) |
906b1b09 | 82 | #:use-module (srfi srfi-19) |
72b9d60d | 83 | #:use-module (srfi srfi-26) |
65797bff LC |
84 | #:use-module (srfi srfi-34) |
85 | #:use-module (srfi srfi-35) | |
523e4896 | 86 | #:use-module (srfi srfi-37) |
25b267af | 87 | #:use-module (ice-9 format) |
523e4896 | 88 | #:use-module (ice-9 match) |
c52bf877 | 89 | #:use-module (rnrs bytevectors) |
731b9962 | 90 | #:export (guix-system |
25261cbf LC |
91 | read-operating-system |
92 | ||
93 | service-node-type | |
94 | shepherd-service-node-type)) | |
523e4896 | 95 | |
8e42796b LC |
96 | \f |
97 | ;;; | |
98 | ;;; Operating system declaration. | |
99 | ;;; | |
100 | ||
523e4896 LC |
101 | (define %user-module |
102 | ;; Module in which the machine description file is loaded. | |
7ea1432e DT |
103 | (make-user-module '((gnu system) |
104 | (gnu services) | |
105 | (gnu system shadow)))) | |
523e4896 LC |
106 | |
107 | (define (read-operating-system file) | |
108 | "Read the operating-system declaration from FILE and return it." | |
7ea1432e | 109 | (load* file %user-module)) |
523e4896 | 110 | |
8e42796b LC |
111 | \f |
112 | ;;; | |
113 | ;;; Installation. | |
114 | ;;; | |
115 | ||
475e2ce2 DM |
116 | (define-syntax-rule (save-load-path-excursion body ...) |
117 | "Save the current values of '%load-path' and '%load-compiled-path', run | |
118 | BODY..., and restore them." | |
119 | (let ((path %load-path) | |
120 | (cpath %load-compiled-path)) | |
121 | (dynamic-wind | |
122 | (const #t) | |
123 | (lambda () | |
124 | body ...) | |
125 | (lambda () | |
126 | (set! %load-path path) | |
127 | (set! %load-compiled-path cpath))))) | |
128 | ||
129 | (define-syntax-rule (save-environment-excursion body ...) | |
130 | "Save the current environment variables, run BODY..., and restore them." | |
131 | (let ((env (environ))) | |
132 | (dynamic-wind | |
133 | (const #t) | |
134 | (lambda () | |
135 | body ...) | |
136 | (lambda () | |
137 | (environ env))))) | |
138 | ||
8e42796b LC |
139 | (define topologically-sorted* |
140 | (store-lift topologically-sorted)) | |
8e42796b LC |
141 | |
142 | ||
1574bd82 | 143 | (define* (copy-item item info target db |
8334cf5b | 144 | #:key (log-port (current-error-port))) |
1574bd82 LC |
145 | "Copy ITEM to the store under root directory TARGET and populate DB with the |
146 | given INFO, a <path-info> record." | |
147 | (let ((dest (string-append target item))) | |
e4ecd51e LC |
148 | (format log-port "copying '~a'...~%" item) |
149 | ||
150 | ;; Remove DEST if it exists to make sure that (1) we do not fail badly | |
151 | ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and | |
152 | ;; (2) we end up with the right contents. | |
f3f1d0a5 LC |
153 | (when (false-if-exception (lstat dest)) |
154 | (for-each make-file-writable | |
155 | (find-files dest (lambda (file stat) | |
156 | (eq? 'directory (stat:type stat))) | |
157 | #:directories? #t)) | |
e4ecd51e LC |
158 | (delete-file-recursively dest)) |
159 | ||
cd6c5ddf LC |
160 | (copy-store-item item target |
161 | #:deduplicate? #t) | |
e4ecd51e | 162 | |
1574bd82 LC |
163 | (sqlite-register db |
164 | #:path item | |
165 | #:references (path-info-references info) | |
166 | #:deriver (path-info-deriver info) | |
167 | #:hash (string-append | |
168 | "sha256:" | |
169 | (bytevector->base16-string (path-info-hash info))) | |
170 | #:nar-size (path-info-nar-size info)))) | |
8e42796b | 171 | |
8334cf5b LC |
172 | (define* (copy-closure item target |
173 | #:key (log-port (current-error-port))) | |
174 | "Copy ITEM and all its dependencies to the store under root directory | |
175 | TARGET, and register them." | |
e4ecd51e | 176 | (mlet* %store-monad ((to-copy (topologically-sorted* (list item))) |
1574bd82 | 177 | (info (mapm %store-monad query-path-info* to-copy)) |
71bf6cb7 | 178 | (size -> (reduce + 0 (map path-info-nar-size info)))) |
e261e276 LC |
179 | (define progress-bar |
180 | (progress-reporter/bar (length to-copy) | |
181 | (format #f (G_ "copying to '~a'...") | |
182 | target))) | |
183 | ||
1574bd82 LC |
184 | (define state |
185 | (string-append target "/var/guix")) | |
186 | ||
71bf6cb7 LC |
187 | (check-available-space size target) |
188 | ||
1574bd82 LC |
189 | ;; Explicitly use "TARGET/var/guix" as the state directory to avoid |
190 | ;; reproducing the user's current settings; see | |
191 | ;; <http://bugs.gnu.org/18049>. | |
192 | (call-with-database (store-database-file #:prefix target | |
193 | #:state-directory state) | |
194 | (lambda (db) | |
195 | (call-with-progress-reporter progress-bar | |
196 | (lambda (report) | |
197 | (let ((void (%make-void-port "w"))) | |
198 | (for-each (lambda (item info) | |
199 | (copy-item item info target db #:log-port void) | |
200 | (report)) | |
201 | to-copy info)))))) | |
e4ecd51e LC |
202 | |
203 | (return *unspecified*))) | |
8334cf5b | 204 | |
8e42796b | 205 | (define* (install os-drv target |
c79d54fe | 206 | #:key (log-port (current-output-port)) |
5c8c8c45 | 207 | install-bootloader? bootloader bootcfg) |
1229d328 | 208 | "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to |
f245b03d | 209 | directory TARGET. TARGET must be an absolute directory name since that's what |
ea0a06ce | 210 | 'register-path' expects. |
c79d54fe | 211 | |
ba015ce9 | 212 | When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG." |
8e42796b LC |
213 | (define (maybe-copy to-copy) |
214 | (with-monad %store-monad | |
215 | (if (string=? target "/") | |
216 | (begin | |
69daee23 | 217 | (warning (G_ "initializing the current root file system~%")) |
8e42796b LC |
218 | (return #t)) |
219 | (begin | |
220 | ;; Make sure the target store exists. | |
221 | (mkdir-p (string-append target (%store-prefix))) | |
222 | ||
223 | ;; Copy items to the new store. | |
8334cf5b | 224 | (copy-closure to-copy target #:log-port log-port))))) |
8e42796b | 225 | |
4a35a866 LC |
226 | ;; Make sure TARGET is root-owned when running as root, but still allow |
227 | ;; non-root uses (useful for testing.) See | |
228 | ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>. | |
229 | (if (zero? (geteuid)) | |
230 | (chown target 0 0) | |
69daee23 | 231 | (warning (G_ "not running as 'root', so \ |
4a35a866 LC |
232 | the ownership of '~a' may be incorrect!~%") |
233 | target)) | |
234 | ||
6c843907 LC |
235 | ;; If a previous installation was attempted, make sure we start anew; in |
236 | ;; particular, we don't want to keep a store database that might not | |
237 | ;; correspond to what we're actually putting in the store. | |
238 | (let ((state (string-append target "/var/guix"))) | |
239 | (when (file-exists? state) | |
240 | (delete-file-recursively state))) | |
241 | ||
4a35a866 | 242 | (chmod target #o755) |
cc7fa592 | 243 | (let ((os-dir (derivation->output-path os-drv)) |
c9e46f1c LC |
244 | (format (lift format %store-monad)) |
245 | (populate (lift2 populate-root-file-system %store-monad))) | |
cc7fa592 | 246 | |
1d6669af LC |
247 | (mlet %store-monad ((bootcfg (lower-object bootcfg))) |
248 | (mbegin %store-monad | |
249 | ;; Copy the closure of BOOTCFG, which includes OS-DIR, | |
250 | ;; eventual background image and so on. | |
251 | (maybe-copy (derivation->output-path bootcfg)) | |
252 | ||
253 | ;; Create a bunch of additional files. | |
254 | (format log-port "populating '~a'...~%" target) | |
255 | (populate os-dir target) | |
256 | ||
257 | (mwhen install-bootloader? | |
5c8c8c45 JK |
258 | (install-bootloader local-eval bootloader bootcfg |
259 | #:target target) | |
260 | (return | |
3f717a09 | 261 | (info (G_ "bootloader successfully installed on~{ ~a~}~%") |
2ca982ff | 262 | (bootloader-configuration-targets bootloader)))))))) |
72b9d60d | 263 | |
523e4896 | 264 | \f |
b25937e3 LC |
265 | ;;; |
266 | ;;; Reconfiguration. | |
267 | ;;; | |
268 | ||
269 | (define %system-profile | |
270 | ;; The system profile. | |
271 | (string-append %state-directory "/profiles/system")) | |
272 | ||
aa1e73a9 LC |
273 | (define-syntax-rule (with-shepherd-error-handling mbody ...) |
274 | "Catch and report Shepherd errors that arise when binding MBODY, a monadic | |
275 | expression in %STORE-MONAD." | |
276 | (lambda (store) | |
af0ba938 LC |
277 | (catch 'system-error |
278 | (lambda () | |
279 | (guard (c ((shepherd-error? c) | |
280 | (values (report-shepherd-error c) store))) | |
73bfb14f | 281 | (values (run-with-store store (mbegin %store-monad mbody ...)) |
af0ba938 LC |
282 | store))) |
283 | (lambda (key proc format-string format-args errno . rest) | |
69daee23 | 284 | (warning (G_ "while talking to shepherd: ~a~%") |
af0ba938 LC |
285 | (apply format #f format-string format-args)) |
286 | (values #f store))))) | |
8bf92e39 LC |
287 | |
288 | (define (report-shepherd-error error) | |
289 | "Report ERROR, a '&shepherd-error' error condition object." | |
7e90e28a LC |
290 | (when error |
291 | (cond ((service-not-found-error? error) | |
292 | (warning (G_ "service '~a' could not be found~%") | |
293 | (service-not-found-error-service error))) | |
294 | ((action-not-found-error? error) | |
295 | (warning (G_ "service '~a' does not have an action '~a'~%") | |
296 | (action-not-found-error-service error) | |
297 | (action-not-found-error-action error))) | |
298 | ((action-exception-error? error) | |
299 | (warning (G_ "exception caught while executing '~a' \ | |
8bf92e39 | 300 | on service '~a':~%") |
7e90e28a LC |
301 | (action-exception-error-action error) |
302 | (action-exception-error-service error)) | |
303 | (print-exception (current-error-port) #f | |
304 | (action-exception-error-key error) | |
305 | (action-exception-error-arguments error))) | |
306 | ((unknown-shepherd-error? error) | |
307 | (warning (G_ "something went wrong: ~s~%") | |
308 | (unknown-shepherd-error-sexp error))) | |
309 | ((shepherd-error? error) | |
310 | (warning (G_ "shepherd error~%")))) | |
311 | ||
312 | ;; Don't leave users out in the cold and explain what that means and what | |
313 | ;; they can do. | |
314 | (warning (G_ "some services could not be upgraded~%")) | |
315 | (display-hint (G_ "To allow changes to all the system services to take | |
316 | effect, you will need to reboot.")))) | |
8bf92e39 | 317 | |
b25937e3 LC |
318 | (define-syntax-rule (unless-file-not-found exp) |
319 | (catch 'system-error | |
320 | (lambda () | |
321 | exp) | |
322 | (lambda args | |
323 | (if (= ENOENT (system-error-errno args)) | |
324 | #f | |
325 | (apply throw args))))) | |
326 | ||
906b1b09 LC |
327 | (define (seconds->string seconds) |
328 | "Return a string representing the date for SECONDS." | |
329 | (let ((time (make-time time-utc 0 seconds))) | |
330 | (date->string (time-utc->date time) | |
331 | "~Y-~m-~d ~H:~M"))) | |
332 | ||
abae042e | 333 | (define* (profile-boot-parameters #:optional (profile %system-profile) |
8fc3a971 MO |
334 | (numbers |
335 | (reverse (generation-numbers profile)))) | |
336 | "Return a list of 'boot-parameters' for the generations of PROFILE specified | |
337 | by NUMBERS, which is a list of generation numbers. The list is ordered from | |
338 | the most recent to the oldest profiles." | |
abae042e DM |
339 | (define (system->boot-parameters system number time) |
340 | (unless-file-not-found | |
0315abe6 DM |
341 | (let* ((params (read-boot-parameters-file system)) |
342 | (label (boot-parameters-label params))) | |
343 | (boot-parameters | |
344 | (inherit params) | |
345 | (label (string-append label " (#" | |
346 | (number->string number) ", " | |
347 | (seconds->string time) ")")))))) | |
abae042e DM |
348 | (let* ((systems (map (cut generation-file-name profile <>) |
349 | numbers)) | |
350 | (times (map (lambda (system) | |
351 | (unless-file-not-found | |
352 | (stat:mtime (lstat system)))) | |
353 | systems))) | |
354 | (filter-map system->boot-parameters systems numbers times))) | |
355 | ||
b25937e3 | 356 | \f |
8074b330 CM |
357 | ;;; |
358 | ;;; Roll-back. | |
359 | ;;; | |
360 | (define (roll-back-system store) | |
361 | "Roll back the system profile to its previous generation. STORE is an open | |
362 | connection to the store." | |
363 | (switch-to-system-generation store "-1")) | |
9d80d0e9 | 364 | |
8074b330 CM |
365 | \f |
366 | ;;; | |
367 | ;;; Switch generations. | |
368 | ;;; | |
369 | (define (switch-to-system-generation store spec) | |
370 | "Switch the system profile to the generation specified by SPEC, and | |
3241f7ff | 371 | re-install bootloader with a configuration file that uses the specified system |
8074b330 | 372 | generation as its default entry. STORE is an open connection to the store." |
236a8829 BW |
373 | (let* ((number (relative-generation-spec->number %system-profile spec)) |
374 | (generation (generation-file-name %system-profile number)) | |
375 | (activate (string-append generation "/activate"))) | |
8074b330 CM |
376 | (if number |
377 | (begin | |
3241f7ff | 378 | (reinstall-bootloader store number) |
236a8829 BW |
379 | (switch-to-generation* %system-profile number) |
380 | (unless-file-not-found (primitive-load activate))) | |
69daee23 | 381 | (leave (G_ "cannot switch to system generation '~a'~%") spec)))) |
8074b330 | 382 | |
3241f7ff MO |
383 | (define* (system-bootloader-name #:optional (system %system-profile)) |
384 | "Return the bootloader name stored in SYSTEM's \"parameters\" file." | |
385 | (let ((params (unless-file-not-found | |
386 | (read-boot-parameters-file system)))) | |
f96752e3 | 387 | (boot-parameters-bootloader-name params))) |
3241f7ff MO |
388 | |
389 | (define (reinstall-bootloader store number) | |
390 | "Re-install bootloader for existing system profile generation NUMBER. | |
391 | STORE is an open connection to the store." | |
8074b330 | 392 | (let* ((generation (generation-file-name %system-profile number)) |
3241f7ff MO |
393 | ;; Detect the bootloader used in %system-profile. |
394 | (bootloader (lookup-bootloader-by-name (system-bootloader-name))) | |
395 | ||
396 | ;; Use the detected bootloader with default configuration. | |
397 | ;; It will be enough to allow the system to boot. | |
398 | (bootloader-config (bootloader-configuration | |
399 | (bootloader bootloader))) | |
400 | ||
8074b330 | 401 | ;; Make the specified system generation the default entry. |
c3e59de9 LC |
402 | (params (first (profile-boot-parameters %system-profile |
403 | (list number)))) | |
eaf09639 | 404 | (locale (boot-parameters-locale params)) |
f00e68ac | 405 | (store-crypto-devices (boot-parameters-store-crypto-devices params)) |
582cf925 MÁAV |
406 | (store-directory-prefix |
407 | (boot-parameters-store-directory-prefix params)) | |
1e969834 LC |
408 | (old-generations |
409 | (delv number (reverse (generation-numbers %system-profile)))) | |
1975c754 DM |
410 | (old-params (profile-boot-parameters |
411 | %system-profile old-generations)) | |
c3e59de9 LC |
412 | (entries (cons (boot-parameters->menu-entry params) |
413 | (boot-parameters-bootloader-menu-entries params))) | |
1975c754 | 414 | (old-entries (map boot-parameters->menu-entry old-params))) |
3241f7ff MO |
415 | (run-with-store store |
416 | (mlet* %store-monad | |
6ddc63e5 LC |
417 | ((bootcfg (lower-object |
418 | ((bootloader-configuration-file-generator bootloader) | |
419 | bootloader-config entries | |
eaf09639 | 420 | #:locale locale |
f00e68ac | 421 | #:store-crypto-devices store-crypto-devices |
582cf925 | 422 | #:store-directory-prefix store-directory-prefix |
6ddc63e5 | 423 | #:old-entries old-entries))) |
3241f7ff MO |
424 | (drvs -> (list bootcfg))) |
425 | (mbegin %store-monad | |
3241f7ff | 426 | (built-derivations drvs) |
5c8c8c45 JK |
427 | ;; Only install bootloader configuration file. |
428 | (install-bootloader local-eval bootloader-config bootcfg | |
429 | #:run-installer? #f)))))) | |
8074b330 CM |
430 | |
431 | \f | |
d6c3267a | 432 | ;;; |
6f305ea5 | 433 | ;;; Graphs. |
d6c3267a LC |
434 | ;;; |
435 | ||
436 | (define (service-node-label service) | |
437 | "Return a label to represent SERVICE." | |
438 | (let ((type (service-kind service)) | |
efe7d19a | 439 | (value (service-value service))) |
d6c3267a LC |
440 | (string-append (symbol->string (service-type-name type)) |
441 | (cond ((or (number? value) (symbol? value)) | |
442 | (string-append " " (object->string value))) | |
443 | ((string? value) | |
444 | (string-append " " value)) | |
445 | ((file-system? value) | |
446 | (string-append " " (file-system-mount-point value))) | |
447 | (else | |
448 | ""))))) | |
449 | ||
450 | (define (service-node-type services) | |
451 | "Return a node type for SERVICES. Since <service> instances are not | |
452 | self-contained (they express dependencies on service types, not on services), | |
453 | we have to create the 'edges' procedure dynamically as a function of the full | |
454 | list of services." | |
455 | (node-type | |
456 | (name "service") | |
457 | (description "the DAG of services") | |
458 | (identifier (lift1 object-address %store-monad)) | |
459 | (label service-node-label) | |
460 | (edges (lift1 (service-back-edges services) %store-monad)))) | |
461 | ||
710fa231 | 462 | (define (shepherd-service-node-label service) |
d4053c71 AK |
463 | "Return a label for a node representing a <shepherd-service>." |
464 | (string-join (map symbol->string (shepherd-service-provision service)))) | |
6f305ea5 | 465 | |
710fa231 | 466 | (define (shepherd-service-node-type services) |
d4053c71 | 467 | "Return a node type for SERVICES, a list of <shepherd-service>." |
6f305ea5 | 468 | (node-type |
710fa231 AK |
469 | (name "shepherd-service") |
470 | (description "the dependency graph of shepherd services") | |
471 | (identifier (lift1 shepherd-service-node-label %store-monad)) | |
472 | (label shepherd-service-node-label) | |
d4053c71 | 473 | (edges (lift1 (shepherd-service-back-edges services) %store-monad)))) |
d6c3267a LC |
474 | |
475 | \f | |
65797bff LC |
476 | ;;; |
477 | ;;; Generations. | |
478 | ;;; | |
479 | ||
480 | (define* (display-system-generation number | |
481 | #:optional (profile %system-profile)) | |
482 | "Display a summary of system generation NUMBER in a human-readable format." | |
60f4564a LC |
483 | (define (display-channel channel) |
484 | (format #t " ~a:~%" (channel-name channel)) | |
485 | (format #t (G_ " repository URL: ~a~%") (channel-url channel)) | |
486 | (when (channel-branch channel) | |
487 | (format #t (G_ " branch: ~a~%") (channel-branch channel))) | |
488 | (format #t (G_ " commit: ~a~%") | |
489 | (if (supports-hyperlinks?) | |
490 | (channel-commit-hyperlink channel) | |
491 | (channel-commit channel)))) | |
492 | ||
65797bff | 493 | (unless (zero? number) |
c52bf877 | 494 | (let* ((generation (generation-file-name profile number)) |
9530e73b | 495 | (params (read-boot-parameters-file generation)) |
c52bf877 | 496 | (label (boot-parameters-label params)) |
f96752e3 | 497 | (bootloader-name (boot-parameters-bootloader-name params)) |
c52bf877 MW |
498 | (root (boot-parameters-root-device params)) |
499 | (root-device (if (bytevector? root) | |
500 | (uuid->string root) | |
501 | root)) | |
60f4564a | 502 | (kernel (boot-parameters-kernel params)) |
b91a73a6 LC |
503 | (multiboot-modules (boot-parameters-multiboot-modules params))) |
504 | (define-values (channels config-file) | |
505 | (system-provenance generation)) | |
506 | ||
65797bff | 507 | (display-generation profile number) |
69daee23 LC |
508 | (format #t (G_ " file name: ~a~%") generation) |
509 | (format #t (G_ " canonical file name: ~a~%") (readlink* generation)) | |
b8300494 | 510 | ;; TRANSLATORS: Please preserve the two-space indentation. |
69daee23 | 511 | (format #t (G_ " label: ~a~%") label) |
f96752e3 | 512 | (format #t (G_ " bootloader: ~a~%") bootloader-name) |
e203f4c2 LC |
513 | |
514 | ;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string must | |
515 | ;; be preserved. They denote conditionals, such that the result will | |
516 | ;; look like: | |
517 | ;; root device: UUID: 12345-678 | |
518 | ;; or: | |
519 | ;; root device: label: "my-root" | |
520 | ;; or just: | |
521 | ;; root device: /dev/sda3 | |
522 | (format #t (G_ " root device: ~[UUID: ~a~;label: ~s~;~a~]~%") | |
523 | (cond ((uuid? root-device) 0) | |
524 | ((file-system-label? root-device) 1) | |
525 | (else 2)) | |
99e676db | 526 | (file-system-device->string root-device)) |
e203f4c2 | 527 | |
60f4564a LC |
528 | (format #t (G_ " kernel: ~a~%") kernel) |
529 | ||
28febfaf JN |
530 | (match multiboot-modules |
531 | (() #f) | |
532 | (((modules . _) ...) | |
533 | (format #t (G_ " multiboot: ~a~%") | |
534 | (string-join modules "\n ")))) | |
535 | ||
b91a73a6 LC |
536 | (unless (null? channels) |
537 | ;; TRANSLATORS: Here "channel" is the same terminology as used in | |
538 | ;; "guix describe" and "guix pull --channels". | |
539 | (format #t (G_ " channels:~%")) | |
540 | (for-each display-channel channels)) | |
541 | (when config-file | |
542 | (format #t (G_ " configuration file: ~a~%") | |
543 | (if (supports-hyperlinks?) | |
544 | (file-hyperlink config-file) | |
545 | config-file)))))) | |
65797bff LC |
546 | |
547 | (define* (list-generations pattern #:optional (profile %system-profile)) | |
548 | "Display in a human-readable format all the system generations matching | |
549 | PATTERN, a string. When PATTERN is #f, display all the system generations." | |
550 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
551 | (raise (condition (&profile-not-found-error | |
552 | (profile profile))))) | |
5c3d4430 | 553 | ((not pattern) |
65797bff LC |
554 | (for-each display-system-generation (profile-generations profile))) |
555 | ((matching-generations pattern profile) | |
556 | => | |
557 | (lambda (numbers) | |
558 | (if (null-list? numbers) | |
559 | (exit 1) | |
560 | (leave-on-EPIPE | |
5c3d4430 | 561 | (for-each display-system-generation numbers))))))) |
65797bff LC |
562 | |
563 | \f | |
9d80d0e9 LC |
564 | ;;; |
565 | ;;; File system declaration checks. | |
566 | ;;; | |
567 | ||
568 | (define (check-file-system-availability file-systems) | |
569 | "Check whether the UUIDs or partition labels that FILE-SYSTEMS refer to, if | |
570 | any, are available. Raise an error if they're not." | |
571 | (define relevant | |
572 | (filter (lambda (fs) | |
573 | (and (file-system-mount? fs) | |
6ddb5960 LC |
574 | (not (member (file-system-type fs) |
575 | %pseudo-file-system-types)) | |
adbdf188 MC |
576 | ;; Don't try to validate network file systems. |
577 | (not (string-prefix? "nfs" (file-system-type fs))) | |
9d80d0e9 LC |
578 | (not (memq 'bind-mount (file-system-flags fs))))) |
579 | file-systems)) | |
580 | ||
581 | (define labeled | |
582 | (filter (lambda (fs) | |
a5acc17a | 583 | (file-system-label? (file-system-device fs))) |
9d80d0e9 LC |
584 | relevant)) |
585 | ||
6ddb5960 LC |
586 | (define literal |
587 | (filter (lambda (fs) | |
a5acc17a | 588 | (string? (file-system-device fs))) |
6ddb5960 LC |
589 | relevant)) |
590 | ||
9d80d0e9 LC |
591 | (define uuid |
592 | (filter (lambda (fs) | |
a5acc17a | 593 | (uuid? (file-system-device fs))) |
9d80d0e9 LC |
594 | relevant)) |
595 | ||
596 | (define fail? #f) | |
597 | ||
598 | (define (file-system-location* fs) | |
9a632277 LC |
599 | (and=> (file-system-location fs) |
600 | source-properties->location)) | |
9d80d0e9 LC |
601 | |
602 | (let-syntax ((error (syntax-rules () | |
603 | ((_ args ...) | |
604 | (begin | |
605 | (set! fail? #t) | |
9a632277 | 606 | (report-error args ...)))))) |
6ddb5960 LC |
607 | (for-each (lambda (fs) |
608 | (catch 'system-error | |
609 | (lambda () | |
610 | (stat (file-system-device fs))) | |
611 | (lambda args | |
612 | (let ((errno (system-error-errno args)) | |
613 | (device (file-system-device fs))) | |
9a632277 LC |
614 | (error (file-system-location* fs) |
615 | (G_ "device '~a' not found: ~a~%") | |
616 | device (strerror errno)) | |
6ddb5960 LC |
617 | (unless (string-prefix? "/" device) |
618 | (display-hint (format #f (G_ "If '~a' is a file system | |
a5acc17a LC |
619 | label, write @code{(file-system-label ~s)} in your @code{device} field.") |
620 | device device))))))) | |
6ddb5960 | 621 | literal) |
9d80d0e9 | 622 | (for-each (lambda (fs) |
a5acc17a LC |
623 | (let ((label (file-system-label->string |
624 | (file-system-device fs)))) | |
625 | (unless (find-partition-by-label label) | |
9a632277 LC |
626 | (error (file-system-location* fs) |
627 | (G_ "file system with label '~a' not found~%") | |
628 | label)))) | |
9d80d0e9 LC |
629 | labeled) |
630 | (for-each (lambda (fs) | |
631 | (unless (find-partition-by-uuid (file-system-device fs)) | |
9a632277 LC |
632 | (error (file-system-location* fs) |
633 | (G_ "file system with UUID '~a' not found~%") | |
9d80d0e9 LC |
634 | (uuid->string (file-system-device fs))))) |
635 | uuid) | |
636 | ||
637 | (when fail? | |
638 | ;; Better be safe than sorry. | |
639 | (exit 1)))) | |
640 | ||
424cea80 | 641 | (define (check-mapped-devices os) |
893d0b0b LC |
642 | "Check that each of MAPPED-DEVICES is valid according to the 'check' |
643 | procedure of its type." | |
424cea80 LC |
644 | (define boot-mapped-devices |
645 | (operating-system-boot-mapped-devices os)) | |
646 | ||
647 | (define (needed-for-boot? md) | |
648 | (memq md boot-mapped-devices)) | |
649 | ||
650 | (define initrd-modules | |
651 | (operating-system-initrd-modules os)) | |
652 | ||
893d0b0b LC |
653 | (for-each (lambda (md) |
654 | (let ((check (mapped-device-kind-check | |
655 | (mapped-device-type md)))) | |
656 | ;; We expect CHECK to raise an exception with a detailed | |
424cea80 LC |
657 | ;; '&message' if something goes wrong. |
658 | (check md | |
659 | #:needed-for-boot? (needed-for-boot? md) | |
660 | #:initrd-modules initrd-modules))) | |
661 | (operating-system-mapped-devices os))) | |
662 | ||
663 | (define (check-initrd-modules os) | |
664 | "Check that modules needed by 'needed-for-boot' file systems in OS are | |
665 | available in the initrd. Note that mapped devices are responsible for | |
666 | checking this by themselves in their 'check' procedure." | |
667 | (define (file-system-/dev fs) | |
668 | (let ((device (file-system-device fs))) | |
a5acc17a LC |
669 | (match device |
670 | ((? string?) | |
671 | device) | |
672 | ((? uuid?) | |
673 | (find-partition-by-uuid device)) | |
674 | ((? file-system-label?) | |
675 | (find-partition-by-label (file-system-label->string device)))))) | |
424cea80 | 676 | |
424cea80 LC |
677 | (define file-systems |
678 | (filter file-system-needed-for-boot? | |
679 | (operating-system-file-systems os))) | |
680 | ||
681 | (for-each (lambda (fs) | |
ca23693d LC |
682 | (check-device-initrd-modules (file-system-/dev fs) |
683 | (operating-system-initrd-modules os) | |
684 | (source-properties->location | |
685 | (file-system-location fs)))) | |
424cea80 | 686 | file-systems)) |
893d0b0b | 687 | |
9d80d0e9 | 688 | \f |
8e42796b LC |
689 | ;;; |
690 | ;;; Action. | |
691 | ;;; | |
692 | ||
6e8cdf1d MO |
693 | (define* (system-derivation-for-action image action |
694 | #:key | |
695 | full-boot? | |
c37cd417 | 696 | volatile? |
b42bfbdf | 697 | (graphic? #t) |
6e8cdf1d MO |
698 | container-shared-network? |
699 | mappings) | |
700 | "Return as a monadic value the derivation for IMAGE according to ACTION." | |
701 | (mlet %store-monad ((target (current-target-system)) | |
702 | (os -> (image-operating-system image)) | |
703 | (image-size -> (image-size image))) | |
bdbd8bf9 MO |
704 | (case action |
705 | ((build init reconfigure) | |
706 | (operating-system-derivation os)) | |
707 | ((container) | |
708 | (container-script | |
709 | os | |
710 | #:mappings mappings | |
711 | #:shared-network? container-shared-network?)) | |
bdbd8bf9 MO |
712 | ((vm) |
713 | (system-qemu-image/shared-store-script os | |
714 | #:full-boot? full-boot? | |
c37cd417 | 715 | #:volatile? volatile? |
b42bfbdf | 716 | #:graphic? graphic? |
bce55cec | 717 | #:disk-image-size image-size |
bdbd8bf9 | 718 | #:mappings mappings)) |
3ed8ddd6 | 719 | ((image disk-image vm-image docker-image) |
6e8cdf1d MO |
720 | (when (eq? action 'disk-image) |
721 | (warning (G_ "'disk-image' is deprecated: use 'image' instead~%"))) | |
722 | (when (eq? action 'vm-image) | |
723 | (warning (G_ "'vm-image' is deprecated: use 'image' instead~%"))) | |
3ed8ddd6 MO |
724 | (when (eq? action 'docker-image) |
725 | (warning (G_ "'docker-image' is deprecated: use 'image' instead~%"))) | |
726 | (lower-object (system-image image)))))) | |
8e42796b | 727 | |
7f949db0 LC |
728 | (define (maybe-suggest-running-guix-pull) |
729 | "Suggest running 'guix pull' if this has never been done before." | |
637db76d LC |
730 | ;; Check whether we're running a 'guix pull'-provided 'guix' command. When |
731 | ;; 'current-profile' returns #f, we may be running the globally-installed | |
732 | ;; 'guix' and thus run the risk of deploying an older 'guix'. See | |
733 | ;; <https://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> | |
734 | (unless (or (current-profile) (getenv "GUIX_UNINSTALLED")) | |
69daee23 LC |
735 | (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%")) |
736 | (warning (G_ "Failing to do that may downgrade your system!~%")))) | |
7f949db0 | 737 | |
52ee4479 LC |
738 | (define (bootloader-installer-script installer |
739 | bootloader device target) | |
3042c5d8 MO |
740 | "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE |
741 | and TARGET arguments." | |
52ee4479 LC |
742 | (scheme-file "bootloader-installer" |
743 | (with-imported-modules '((gnu build bootloader) | |
744 | (guix build utils)) | |
745 | #~(begin | |
746 | (use-modules (gnu build bootloader) | |
747 | (guix build utils) | |
21fcfe1e LC |
748 | (ice-9 binary-ports) |
749 | (srfi srfi-34) | |
750 | (srfi srfi-35)) | |
751 | ||
752 | (guard (c ((message-condition? c) ;XXX: i18n | |
753 | (format (current-error-port) "error: ~a~%" | |
754 | (condition-message c)) | |
755 | (exit 1))) | |
756 | (#$installer #$bootloader #$device #$target) | |
5c8c8c45 JK |
757 | (info (G_ "bootloader successfully installed on '~a'~%") |
758 | #$device)))))) | |
759 | ||
760 | (define (local-eval exp) | |
761 | "Evaluate EXP, a G-Expression, in-place." | |
762 | (mlet* %store-monad ((lowered (lower-gexp exp)) | |
763 | (_ (built-derivations (lowered-gexp-inputs lowered)))) | |
764 | (save-load-path-excursion | |
765 | (set! %load-path (lowered-gexp-load-path lowered)) | |
766 | (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered)) | |
767 | (return (primitive-eval (lowered-gexp-sexp lowered)))))) | |
3042c5d8 | 768 | |
6e8cdf1d | 769 | (define* (perform-action action image |
b85836d3 | 770 | #:key |
8e31736b | 771 | (validate-reconfigure ensure-forward-reconfigure) |
b85836d3 LC |
772 | save-provenance? |
773 | skip-safety-checks? | |
61b1dbbd | 774 | install-bootloader? |
1229d328 | 775 | dry-run? derivations-only? |
2ca982ff | 776 | use-substitutes? target |
6e8cdf1d | 777 | full-boot? |
2d12ec72 | 778 | volatile-vm-root? |
b42bfbdf | 779 | (graphic? #t) |
6e8cdf1d | 780 | container-shared-network? |
5ea69d9a CM |
781 | (mappings '()) |
782 | (gc-root #f)) | |
6e8cdf1d | 783 | "Perform ACTION for IMAGE. INSTALL-BOOTLOADER? specifies whether to install |
2ca982ff | 784 | bootloader; TARGET is the target root directory. |
313f4926 MO |
785 | |
786 | FULL-BOOT? is used for the 'vm' action; it determines whether to | |
787 | boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK? | |
788 | determines if the container will use a separate network namespace. | |
f3f427c2 LC |
789 | |
790 | When DERIVATIONS-ONLY? is true, print the derivation file name(s) without | |
5ea69d9a CM |
791 | building anything. |
792 | ||
793 | When GC-ROOT is a path, also make that path an indirect root of the build | |
61b1dbbd LC |
794 | output when building a system derivation, such as a disk image. |
795 | ||
796 | When SKIP-SAFETY-CHECKS? is true, skip the file system and initrd module | |
797 | static checks." | |
f3f427c2 LC |
798 | (define println |
799 | (cut format #t "~a~%" <>)) | |
800 | ||
ab6caf4f LC |
801 | (define menu-entries |
802 | (if (eq? 'init action) | |
803 | '() | |
804 | (map boot-parameters->menu-entry (profile-boot-parameters)))) | |
805 | ||
6e8cdf1d MO |
806 | (define os |
807 | (image-operating-system image)) | |
808 | ||
ab6caf4f | 809 | (define bootloader |
5c8c8c45 | 810 | (operating-system-bootloader os)) |
ab6caf4f LC |
811 | |
812 | (define bootcfg | |
af41e504 | 813 | (and (memq action '(init reconfigure)) |
ab6caf4f LC |
814 | (operating-system-bootcfg os menu-entries))) |
815 | ||
7f949db0 | 816 | (when (eq? action 'reconfigure) |
8e31736b LC |
817 | (maybe-suggest-running-guix-pull) |
818 | (check-forward-update validate-reconfigure)) | |
7f949db0 | 819 | |
9d80d0e9 LC |
820 | ;; Check whether the declared file systems exist. This is better than |
821 | ;; instantiating a broken configuration. Assume that we can only check if | |
822 | ;; running as root. | |
61b1dbbd LC |
823 | (when (and (not skip-safety-checks?) |
824 | (memq action '(init reconfigure))) | |
424cea80 | 825 | (check-mapped-devices os) |
893d0b0b | 826 | (when (zero? (getuid)) |
424cea80 LC |
827 | (check-file-system-availability (operating-system-file-systems os)) |
828 | (check-initrd-modules os))) | |
9d80d0e9 | 829 | |
8e42796b | 830 | (mlet* %store-monad |
6e8cdf1d | 831 | ((sys (system-derivation-for-action image action |
0276f697 | 832 | #:full-boot? full-boot? |
2d12ec72 MO |
833 | #:volatile? |
834 | volatile-vm-root? | |
b42bfbdf | 835 | #:graphic? graphic? |
b33454ae | 836 | #:container-shared-network? container-shared-network? |
0276f697 | 837 | #:mappings mappings)) |
3042c5d8 MO |
838 | |
839 | ;; For 'init' and 'reconfigure', always build BOOTCFG, even if | |
840 | ;; --no-bootloader is passed, because we then use it as a GC root. | |
841 | ;; See <http://bugs.gnu.org/21068>. | |
2ad6eb05 LC |
842 | (drvs (mapm/accumulate-builds lower-object |
843 | (if (memq action '(init reconfigure)) | |
844 | (list sys bootcfg) | |
845 | (list sys)))) | |
f3f427c2 LC |
846 | (% (if derivations-only? |
847 | (return (for-each (compose println derivation-file-name) | |
848 | drvs)) | |
a0f480d6 | 849 | (built-derivations drvs)))) |
8e42796b | 850 | |
f3f427c2 | 851 | (if (or dry-run? derivations-only?) |
8e42796b | 852 | (return #f) |
5c8c8c45 | 853 | (begin |
f3f427c2 LC |
854 | (for-each (compose println derivation->output-path) |
855 | drvs) | |
8e42796b | 856 | |
8e42796b LC |
857 | (case action |
858 | ((reconfigure) | |
5c8c8c45 JK |
859 | (newline) |
860 | (format #t (G_ "activating system...~%")) | |
c3e79cde | 861 | (mbegin %store-monad |
5c8c8c45 | 862 | (switch-to-system local-eval os) |
1229d328 | 863 | (mwhen install-bootloader? |
5c8c8c45 JK |
864 | (install-bootloader local-eval bootloader bootcfg |
865 | #:target (or target "/")) | |
866 | (return | |
867 | (info (G_ "bootloader successfully installed on '~a'~%") | |
2ca982ff | 868 | (bootloader-configuration-targets bootloader)))) |
5c8c8c45 | 869 | (with-shepherd-error-handling |
2ca982ff MC |
870 | (upgrade-shepherd-services local-eval os) |
871 | (return (format #t (G_ "\ | |
73bfb14f | 872 | To complete the upgrade, run 'herd restart SERVICE' to stop, |
a4e81ff3 | 873 | upgrade, and restart each service that was not automatically restarted.\n"))) |
2ca982ff | 874 | (return (format #t (G_ "\ |
a4e81ff3 | 875 | Run 'herd status' to view the list of services on your system.\n")))))) |
8e42796b LC |
876 | ((init) |
877 | (newline) | |
69daee23 | 878 | (format #t (G_ "initializing operating system under '~a'...~%") |
8e42796b LC |
879 | target) |
880 | (install sys (canonicalize-path target) | |
1229d328 | 881 | #:install-bootloader? install-bootloader? |
5c8c8c45 JK |
882 | #:bootloader bootloader |
883 | #:bootcfg bootcfg)) | |
8e42796b | 884 | (else |
5ea69d9a CM |
885 | ;; All we had to do was to build SYS and maybe register an |
886 | ;; indirect GC root. | |
887 | (let ((output (derivation->output-path sys))) | |
888 | (mbegin %store-monad | |
889 | (mwhen gc-root | |
890 | (register-root* (list output) gc-root)) | |
891 | (return output))))))))) | |
8e42796b | 892 | |
6c3690fc LC |
893 | (define* (export-extension-graph os port |
894 | #:key (backend (lookup-backend "graphviz"))) | |
895 | "Export the service extension graph of OS to PORT using BACKEND." | |
d6c3267a | 896 | (let* ((services (operating-system-services os)) |
d62e201c LC |
897 | (system (find (lambda (service) |
898 | (eq? (service-kind service) system-service-type)) | |
d6c3267a | 899 | services))) |
d62e201c | 900 | (export-graph (list system) (current-output-port) |
6c3690fc | 901 | #:backend backend |
d6c3267a LC |
902 | #:node-type (service-node-type services) |
903 | #:reverse-edges? #t))) | |
904 | ||
6c3690fc LC |
905 | (define* (export-shepherd-graph os port |
906 | #:key (backend (lookup-backend "graphviz"))) | |
907 | "Export the graph of shepherd services of OS to PORT using BACKEND." | |
d4053c71 AK |
908 | (let* ((services (operating-system-services os)) |
909 | (pid1 (fold-services services | |
910 | #:target-type shepherd-root-service-type)) | |
95f72dcd MD |
911 | ;; Get the list of <shepherd-service>. |
912 | (shepherds (shepherd-configuration-services (service-value pid1))) | |
d4053c71 AK |
913 | (sinks (filter (lambda (service) |
914 | (null? (shepherd-service-requirement service))) | |
915 | shepherds))) | |
6f305ea5 | 916 | (export-graph sinks (current-output-port) |
6c3690fc | 917 | #:backend backend |
710fa231 | 918 | #:node-type (shepherd-service-node-type shepherds) |
6f305ea5 LC |
919 | #:reverse-edges? #t))) |
920 | ||
8e42796b | 921 | \f |
313f4926 MO |
922 | ;;; |
923 | ;;; Images. | |
924 | ;;; | |
925 | ||
926 | (define (list-image-types) | |
927 | "Print the available image types." | |
928 | (display (G_ "The available image types are:\n")) | |
929 | (newline) | |
930 | (format #t "~{ - ~a ~%~}" (map image-type-name (force %image-types)))) | |
931 | ||
932 | \f | |
523e4896 LC |
933 | ;;; |
934 | ;;; Options. | |
935 | ;;; | |
936 | ||
937 | (define (show-help) | |
69daee23 | 938 | (display (G_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE] |
8074b330 CM |
939 | Build the operating system declared in FILE according to ACTION. |
940 | Some ACTIONS support additional ARGS.\n")) | |
7889394e | 941 | (newline) |
69daee23 | 942 | (display (G_ "The valid values for ACTION are:\n")) |
2a4e2e4b | 943 | (newline) |
0649321d LC |
944 | (display (G_ "\ |
945 | search search for existing service types\n")) | |
69daee23 | 946 | (display (G_ "\ |
2a4e2e4b | 947 | reconfigure switch to a new operating system configuration\n")) |
69daee23 | 948 | (display (G_ "\ |
8074b330 | 949 | roll-back switch to the previous operating system configuration\n")) |
158032bd LC |
950 | (display (G_ "\ |
951 | describe describe the current system\n")) | |
499b166d LC |
952 | (display (G_ "\ |
953 | list-generations list the system generations\n")) | |
69daee23 | 954 | (display (G_ "\ |
8074b330 | 955 | switch-generation switch to an existing operating system configuration\n")) |
69daee23 | 956 | (display (G_ "\ |
499b166d | 957 | delete-generations delete old system generations\n")) |
69daee23 | 958 | (display (G_ "\ |
2a4e2e4b | 959 | build build the operating system without installing anything\n")) |
69daee23 | 960 | (display (G_ "\ |
fbd213a8 | 961 | container build a container that shares the host's store\n")) |
69daee23 | 962 | (display (G_ "\ |
2a4e2e4b | 963 | vm build a virtual machine image that shares the host's store\n")) |
69daee23 | 964 | (display (G_ "\ |
e74baa12 | 965 | image build a Guix System image\n")) |
a335f6fc CM |
966 | (display (G_ "\ |
967 | docker-image build a Docker image\n")) | |
69daee23 | 968 | (display (G_ "\ |
d6c3267a | 969 | init initialize a root file system to run GNU\n")) |
69daee23 | 970 | (display (G_ "\ |
d6c3267a | 971 | extension-graph emit the service extension graph in Dot format\n")) |
69daee23 | 972 | (display (G_ "\ |
710fa231 | 973 | shepherd-graph emit the graph of shepherd services in Dot format\n")) |
7889394e | 974 | |
523e4896 | 975 | (show-build-options-help) |
69daee23 | 976 | (display (G_ " |
f3f427c2 | 977 | -d, --derivation return the derivation of the given system")) |
5a72ddf1 MO |
978 | (display (G_ " |
979 | -e, --expression=EXPR consider the operating-system EXPR evaluates to | |
980 | instead of reading FILE, when applicable")) | |
8e31736b LC |
981 | (display (G_ " |
982 | --allow-downgrades for 'reconfigure', allow downgrades to earlier | |
983 | channel revisions")) | |
69daee23 | 984 | (display (G_ " |
db030303 | 985 | --on-error=STRATEGY |
bd5a81f9 | 986 | apply STRATEGY (one of nothing-special, backtrace, |
987 | or debug) when an error occurs while reading FILE")) | |
3f4d8a7f | 988 | (display (G_ " |
313f4926 MO |
989 | --list-image-types list available image types")) |
990 | (display (G_ " | |
e74baa12 | 991 | -t, --image-type=TYPE for 'image', produce an image of TYPE")) |
69daee23 | 992 | (display (G_ " |
ee2a5da8 | 993 | --image-size=SIZE for 'image', produce an image of SIZE")) |
69daee23 | 994 | (display (G_ " |
a9eadc06 | 995 | --no-bootloader for 'init', do not install a bootloader")) |
41f27bf8 | 996 | (display (G_ " |
e74baa12 | 997 | --volatile for 'image', make the root file system volatile")) |
2d12ec72 MO |
998 | (display (G_ " |
999 | --persistent for 'vm', make the root file system persistent")) | |
036f23f0 | 1000 | (display (G_ " |
e74baa12 | 1001 | --label=LABEL for 'image', label disk image with LABEL")) |
b85836d3 LC |
1002 | (display (G_ " |
1003 | --save-provenance save provenance information")) | |
69daee23 | 1004 | (display (G_ " |
da09b47b EF |
1005 | --share=SPEC for 'vm' and 'container', share host file system with |
1006 | read/write access according to SPEC")) | |
b85836d3 | 1007 | (display (G_ " |
da09b47b EF |
1008 | --expose=SPEC for 'vm' and 'container', expose host file system |
1009 | directory as read-only according to SPEC")) | |
69daee23 | 1010 | (display (G_ " |
b33454ae AI |
1011 | -N, --network for 'container', allow containers to access the network")) |
1012 | (display (G_ " | |
ee2a5da8 MO |
1013 | -r, --root=FILE for 'vm', 'image', 'container' and 'build', |
1014 | make FILE a symlink to the result, and | |
5ea69d9a | 1015 | register it as a garbage collector root")) |
69daee23 | 1016 | (display (G_ " |
ab11f0be | 1017 | --full-boot for 'vm', make a full boot sequence")) |
b42bfbdf AL |
1018 | (display (G_ " |
1019 | --no-graphic for 'vm', use the tty that we are started in for IO")) | |
61b1dbbd LC |
1020 | (display (G_ " |
1021 | --skip-checks skip file system and initrd module safety checks")) | |
fcc4c6ae MO |
1022 | (display (G_ " |
1023 | --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) | |
f1de676e LC |
1024 | (display (G_ " |
1025 | -v, --verbosity=LEVEL use the given verbosity LEVEL")) | |
523e4896 | 1026 | (newline) |
6c3690fc LC |
1027 | (display (G_ " |
1028 | --graph-backend=BACKEND | |
1029 | use BACKEND for 'extension-graphs' and 'shepherd-graph'")) | |
1030 | (newline) | |
69daee23 | 1031 | (display (G_ " |
523e4896 | 1032 | -h, --help display this help and exit")) |
69daee23 | 1033 | (display (G_ " |
523e4896 LC |
1034 | -V, --version display version information and exit")) |
1035 | (newline) | |
1036 | (show-bug-report-information)) | |
1037 | ||
1038 | (define %options | |
1039 | ;; Specifications of the command-line options. | |
1040 | (cons* (option '(#\h "help") #f #f | |
1041 | (lambda args | |
1042 | (show-help) | |
1043 | (exit 0))) | |
1044 | (option '(#\V "version") #f #f | |
1045 | (lambda args | |
1046 | (show-version-and-exit "guix system"))) | |
5a72ddf1 MO |
1047 | (option '(#\e "expression") #t #f |
1048 | (lambda (opt name arg result) | |
1049 | (alist-cons 'expression arg result))) | |
f3f427c2 LC |
1050 | (option '(#\d "derivation") #f #f |
1051 | (lambda (opt name arg result) | |
1052 | (alist-cons 'derivations-only? #t result))) | |
8e31736b LC |
1053 | (option '("allow-downgrades") #f #f |
1054 | (lambda (opt name arg result) | |
1055 | (alist-cons 'validate-reconfigure | |
1056 | warn-about-backward-reconfigure | |
1057 | result))) | |
db030303 LC |
1058 | (option '("on-error") #t #f |
1059 | (lambda (opt name arg result) | |
1060 | (alist-cons 'on-error (string->symbol arg) | |
1061 | result))) | |
313f4926 | 1062 | (option '(#\t "image-type") #t #f |
3f4d8a7f | 1063 | (lambda (opt name arg result) |
313f4926 | 1064 | (alist-cons 'image-type (string->symbol arg) |
3f4d8a7f | 1065 | result))) |
313f4926 MO |
1066 | (option '("list-image-types") #f #f |
1067 | (lambda (opt name arg result) | |
1068 | (list-image-types) | |
1069 | (exit 0))) | |
2e7b5cea LC |
1070 | (option '("image-size") #t #f |
1071 | (lambda (opt name arg result) | |
1072 | (alist-cons 'image-size (size->number arg) | |
1073 | result))) | |
b33454ae AI |
1074 | (option '(#\N "network") #f #f |
1075 | (lambda (opt name arg result) | |
1076 | (alist-cons 'container-shared-network? #t result))) | |
a9eadc06 | 1077 | (option '("no-bootloader" "no-grub") #f #f |
c79d54fe | 1078 | (lambda (opt name arg result) |
e61519ab | 1079 | (alist-cons 'install-bootloader? #f result))) |
41f27bf8 MC |
1080 | (option '("volatile") #f #f |
1081 | (lambda (opt name arg result) | |
2d12ec72 MO |
1082 | (alist-cons 'volatile-image-root? #t result))) |
1083 | (option '("persistent") #f #f | |
1084 | (lambda (opt name arg result) | |
1085 | (alist-cons 'volatile-vm-root? #f result))) | |
036f23f0 JL |
1086 | (option '("label") #t #f |
1087 | (lambda (opt name arg result) | |
1088 | (alist-cons 'label arg result))) | |
ab11f0be LC |
1089 | (option '("full-boot") #f #f |
1090 | (lambda (opt name arg result) | |
1091 | (alist-cons 'full-boot? #t result))) | |
b42bfbdf AL |
1092 | (option '("no-graphic") #f #f |
1093 | (lambda (opt name arg result) | |
1094 | (alist-cons 'no-graphic? #t result))) | |
b85836d3 LC |
1095 | (option '("save-provenance") #f #f |
1096 | (lambda (opt name arg result) | |
1097 | (alist-cons 'save-provenance? #t result))) | |
61b1dbbd LC |
1098 | (option '("skip-checks") #f #f |
1099 | (lambda (opt name arg result) | |
1100 | (alist-cons 'skip-safety-checks? #t result))) | |
0276f697 LC |
1101 | |
1102 | (option '("share") #t #f | |
1103 | (lambda (opt name arg result) | |
1104 | (alist-cons 'file-system-mapping | |
1105 | (specification->file-system-mapping arg #t) | |
1106 | result))) | |
1107 | (option '("expose") #t #f | |
1108 | (lambda (opt name arg result) | |
1109 | (alist-cons 'file-system-mapping | |
1110 | (specification->file-system-mapping arg #f) | |
1111 | result))) | |
1112 | ||
523e4896 LC |
1113 | (option '(#\n "dry-run") #f #f |
1114 | (lambda (opt name arg result) | |
131f50cd | 1115 | (alist-cons 'dry-run? #t result))) |
f1de676e LC |
1116 | (option '(#\v "verbosity") #t #f |
1117 | (lambda (opt name arg result) | |
1118 | (let ((level (string->number* arg))) | |
1119 | (alist-cons 'verbosity level | |
1120 | (alist-delete 'verbosity result))))) | |
df2ce343 LC |
1121 | (option '(#\s "system") #t #f |
1122 | (lambda (opt name arg result) | |
1123 | (alist-cons 'system arg | |
1124 | (alist-delete 'system result eq?)))) | |
fcc4c6ae MO |
1125 | (option '("target") #t #f |
1126 | (lambda (opt name arg result) | |
1127 | (alist-cons 'target arg | |
1128 | (alist-delete 'target result eq?)))) | |
5ea69d9a CM |
1129 | (option '(#\r "root") #t #f |
1130 | (lambda (opt name arg result) | |
1131 | (alist-cons 'gc-root arg result))) | |
6c3690fc LC |
1132 | (option '("graph-backend") #t #f |
1133 | (lambda (opt name arg result) | |
1134 | (alist-cons 'graph-backend arg result))) | |
523e4896 LC |
1135 | %standard-build-options)) |
1136 | ||
1137 | (define %default-options | |
1138 | ;; Alist of default option values. | |
1139 | `((system . ,(%current-system)) | |
fcc4c6ae | 1140 | (target . #f) |
523e4896 | 1141 | (substitutes? . #t) |
7f44ab48 | 1142 | (offload? . #t) |
dc0f74e5 LC |
1143 | (print-build-trace? . #t) |
1144 | (print-extended-build-trace? . #t) | |
f9a8fce1 | 1145 | (multiplexed-build-output? . #t) |
7920e187 | 1146 | (graft? . #t) |
f1de676e LC |
1147 | (debug . 0) |
1148 | (verbosity . #f) ;default | |
8e31736b | 1149 | (validate-reconfigure . ,ensure-forward-reconfigure) |
2f497d94 | 1150 | (image-type . efi-raw) |
a8ac4f08 | 1151 | (image-size . guess) |
036f23f0 | 1152 | (install-bootloader? . #t) |
41f27bf8 | 1153 | (label . #f) |
2d12ec72 MO |
1154 | (volatile-image-root? . #f) |
1155 | (volatile-vm-root? . #t) | |
6c3690fc | 1156 | (graph-backend . "graphviz"))) |
523e4896 | 1157 | |
898e6d0a LC |
1158 | (define (verbosity-level opts) |
1159 | "Return the verbosity level based on OPTS, the alist of parsed options." | |
1160 | (or (assoc-ref opts 'verbosity) | |
1161 | (if (eq? (assoc-ref opts 'action) 'build) | |
e18e2e45 | 1162 | 3 1))) |
898e6d0a | 1163 | |
523e4896 LC |
1164 | \f |
1165 | ;;; | |
1166 | ;;; Entry point. | |
1167 | ;;; | |
1168 | ||
b8b56bad | 1169 | (define actions '("build" "container" "vm" "vm-image" "image" "disk-image" |
1170 | "reconfigure" "init" | |
1171 | "extension-graph" "shepherd-graph" | |
1172 | "list-generations" "describe" | |
1173 | "delete-generations" "roll-back" | |
1174 | "switch-generation" "search" "docker-image")) | |
1175 | ||
deaab8e3 | 1176 | (define (process-action action args opts) |
65797bff LC |
1177 | "Process ACTION, a sub-command, with the arguments are listed in ARGS. |
1178 | ACTION must be one of the sub-commands that takes an operating system | |
1179 | declaration as an argument (a file name.) OPTS is the raw alist of options | |
1180 | resulting from command-line parsing." | |
6e8cdf1d MO |
1181 | (define (ensure-operating-system-or-image file-or-exp obj) |
1182 | (unless (or (operating-system? obj) (image? obj)) | |
1183 | (leave (G_ "'~a' does not return an operating system or an image~%") | |
ce10e605 LC |
1184 | file-or-exp)) |
1185 | obj) | |
1186 | ||
b85836d3 LC |
1187 | (define save-provenance? |
1188 | (or (assoc-ref opts 'save-provenance?) | |
1189 | (memq action '(init reconfigure)))) | |
1190 | ||
e61519ab MO |
1191 | (let* ((file (match args |
1192 | (() #f) | |
1193 | ((x . _) x))) | |
5a72ddf1 | 1194 | (expr (assoc-ref opts 'expression)) |
e61519ab | 1195 | (system (assoc-ref opts 'system)) |
fcc4c6ae | 1196 | (target (assoc-ref opts 'target)) |
6e8cdf1d MO |
1197 | (transform (lambda (obj) |
1198 | (if (and save-provenance? (operating-system? obj)) | |
1199 | (operating-system-with-provenance obj file) | |
1200 | obj))) | |
1201 | (obj (transform | |
1202 | (ensure-operating-system-or-image | |
1203 | (or file expr) | |
1204 | (cond | |
1205 | ((and expr file) | |
1206 | (leave | |
1207 | (G_ "both file and expression cannot be specified~%"))) | |
1208 | (expr | |
1209 | (read/eval expr)) | |
1210 | (file | |
1211 | (load* file %user-module | |
1212 | #:on-error (assoc-ref opts 'on-error))) | |
1213 | (else | |
1214 | (leave (G_ "no configuration specified~%"))))))) | |
e61519ab MO |
1215 | (dry? (assoc-ref opts 'dry-run?)) |
1216 | (bootloader? (assoc-ref opts 'install-bootloader?)) | |
036f23f0 | 1217 | (label (assoc-ref opts 'label)) |
6e8cdf1d MO |
1218 | (image-type (lookup-image-type-by-name |
1219 | (assoc-ref opts 'image-type))) | |
3ed8ddd6 MO |
1220 | (image (let* ((image-type (case action |
1221 | ((vm-image) qcow2-image-type) | |
1222 | ((docker-image) docker-image-type) | |
1223 | (else image-type))) | |
6e8cdf1d | 1224 | (image-size (assoc-ref opts 'image-size)) |
2d12ec72 MO |
1225 | (volatile? |
1226 | (assoc-ref opts 'volatile-image-root?)) | |
3ed8ddd6 MO |
1227 | (shared-network? |
1228 | (assoc-ref opts 'container-shared-network?)) | |
6e8cdf1d MO |
1229 | (base-image (if (operating-system? obj) |
1230 | (os->image obj | |
1231 | #:type image-type) | |
d5073fd1 | 1232 | obj))) |
6e8cdf1d MO |
1233 | (image |
1234 | (inherit (if label | |
1235 | (image-with-label base-image label) | |
1236 | base-image)) | |
6e8cdf1d | 1237 | (size image-size) |
3ed8ddd6 MO |
1238 | (volatile-root? volatile?) |
1239 | (shared-network? shared-network?)))) | |
6e8cdf1d | 1240 | (os (image-operating-system image)) |
fcc4c6ae | 1241 | (target-file (match args |
e61519ab MO |
1242 | ((first second) second) |
1243 | (_ #f))) | |
2ca982ff | 1244 | (bootloader-targets |
045ebb3e | 1245 | (and bootloader? |
2ca982ff | 1246 | (bootloader-configuration-targets |
e61519ab | 1247 | (operating-system-bootloader os))))) |
deaab8e3 | 1248 | |
6c3690fc LC |
1249 | (define (graph-backend) |
1250 | (lookup-backend (assoc-ref opts 'graph-backend))) | |
1251 | ||
deaab8e3 LC |
1252 | (with-store store |
1253 | (set-build-options-from-command-line store opts) | |
1254 | ||
a0f480d6 LC |
1255 | (with-build-handler (build-notifier #:use-substitutes? |
1256 | (assoc-ref opts 'substitutes?) | |
898e6d0a LC |
1257 | #:verbosity |
1258 | (verbosity-level opts) | |
a0f480d6 LC |
1259 | #:dry-run? |
1260 | (assoc-ref opts 'dry-run?)) | |
1261 | (run-with-store store | |
1262 | (mbegin %store-monad | |
1263 | (set-guile-for-build (default-guile)) | |
1264 | (case action | |
1265 | ((extension-graph) | |
6c3690fc LC |
1266 | (export-extension-graph os (current-output-port) |
1267 | #:backend (graph-backend))) | |
a0f480d6 | 1268 | ((shepherd-graph) |
6c3690fc LC |
1269 | (export-shepherd-graph os (current-output-port) |
1270 | #:backend (graph-backend))) | |
a0f480d6 LC |
1271 | (else |
1272 | (unless (memq action '(build init)) | |
1273 | (warn-about-old-distro #:suggested-command | |
1274 | "guix system reconfigure")) | |
1275 | ||
6e8cdf1d | 1276 | (perform-action action image |
a0f480d6 LC |
1277 | #:dry-run? dry? |
1278 | #:derivations-only? (assoc-ref opts | |
1279 | 'derivations-only?) | |
1280 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
1281 | #:skip-safety-checks? | |
1282 | (assoc-ref opts 'skip-safety-checks?) | |
8e31736b LC |
1283 | #:validate-reconfigure |
1284 | (assoc-ref opts 'validate-reconfigure) | |
a0f480d6 | 1285 | #:full-boot? (assoc-ref opts 'full-boot?) |
2d12ec72 MO |
1286 | #:volatile-vm-root? |
1287 | (assoc-ref opts 'volatile-vm-root?) | |
b42bfbdf | 1288 | #:graphic? (not (assoc-ref opts 'no-graphic?)) |
a0f480d6 LC |
1289 | #:container-shared-network? |
1290 | (assoc-ref opts 'container-shared-network?) | |
1291 | #:mappings (filter-map (match-lambda | |
1292 | (('file-system-mapping . m) | |
1293 | m) | |
1294 | (_ #f)) | |
1295 | opts) | |
1296 | #:install-bootloader? bootloader? | |
1297 | #:target target-file | |
a0f480d6 LC |
1298 | #:gc-root (assoc-ref opts 'gc-root))))) |
1299 | #:target target | |
1300 | #:system system))) | |
62a14bd2 | 1301 | (warn-about-disk-space))) |
deaab8e3 | 1302 | |
0649321d LC |
1303 | (define (resolve-subcommand name) |
1304 | (let ((module (resolve-interface | |
1305 | `(guix scripts system ,(string->symbol name)))) | |
1306 | (proc (string->symbol (string-append "guix-system-" name)))) | |
1307 | (module-ref module proc))) | |
1308 | ||
65797bff LC |
1309 | (define (process-command command args opts) |
1310 | "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its | |
1311 | argument list and OPTS is the option alist." | |
89bbcc80 LC |
1312 | (define-syntax-rule (with-store* store exp ...) |
1313 | (with-store store | |
1314 | (set-build-options-from-command-line store opts) | |
1315 | exp ...)) | |
1316 | ||
65797bff | 1317 | (case command |
8074b330 CM |
1318 | ;; The following commands do not need to use the store, and they do not need |
1319 | ;; an operating system configuration file. | |
65797bff | 1320 | ((list-generations) |
65797bff | 1321 | (let ((pattern (match args |
5c3d4430 | 1322 | (() #f) |
65797bff | 1323 | ((pattern) pattern) |
69daee23 | 1324 | (x (leave (G_ "wrong number of arguments~%")))))) |
65797bff | 1325 | (list-generations pattern))) |
158032bd | 1326 | ((describe) |
79106973 LC |
1327 | ;; Describe the running system, which is not necessarily the current |
1328 | ;; generation. /run/current-system might point to | |
1329 | ;; /var/guix/profiles/system-N-link, or it might point directly to | |
1330 | ;; /gnu/store/…-system. Try both. | |
9679123c | 1331 | (match (generation-number "/run/current-system" %system-profile) |
158032bd | 1332 | (0 |
79106973 LC |
1333 | (match (generation-number %system-profile) |
1334 | (0 | |
1335 | (leave (G_ "no system generation, nothing to describe~%"))) | |
1336 | (generation | |
1337 | (display-system-generation generation)))) | |
158032bd LC |
1338 | (generation |
1339 | (display-system-generation generation)))) | |
0649321d LC |
1340 | ((search) |
1341 | (apply (resolve-subcommand "search") args)) | |
8074b330 CM |
1342 | ;; The following commands need to use the store, but they do not need an |
1343 | ;; operating system configuration file. | |
499b166d LC |
1344 | ((delete-generations) |
1345 | (let ((pattern (match args | |
5c3d4430 | 1346 | (() #f) |
499b166d LC |
1347 | ((pattern) pattern) |
1348 | (x (leave (G_ "wrong number of arguments~%")))))) | |
89bbcc80 | 1349 | (with-store* store |
499b166d LC |
1350 | (delete-matching-generations store %system-profile pattern) |
1351 | (reinstall-bootloader store (generation-number %system-profile))))) | |
8074b330 CM |
1352 | ((switch-generation) |
1353 | (let ((pattern (match args | |
1354 | ((pattern) pattern) | |
69daee23 | 1355 | (x (leave (G_ "wrong number of arguments~%")))))) |
89bbcc80 | 1356 | (with-store* store |
8074b330 CM |
1357 | (switch-to-system-generation store pattern)))) |
1358 | ((roll-back) | |
1359 | (let ((pattern (match args | |
1360 | (() "") | |
69daee23 | 1361 | (x (leave (G_ "wrong number of arguments~%")))))) |
89bbcc80 | 1362 | (with-store* store |
8074b330 CM |
1363 | (roll-back-system store)))) |
1364 | ;; The following commands need to use the store, and they also | |
1365 | ;; need an operating system configuration file. | |
1366 | (else (process-action command args opts)))) | |
65797bff | 1367 | |
3794ce93 LC |
1368 | (define-command (guix-system . args) |
1369 | (synopsis "build and deploy full operating systems") | |
1370 | ||
b3f21389 LC |
1371 | (define (parse-sub-command arg result) |
1372 | ;; Parse sub-command ARG and augment RESULT accordingly. | |
b8b56bad | 1373 | (cond ((assoc-ref result 'action) |
1374 | (alist-cons 'argument arg result)) | |
1375 | ((member arg actions) | |
1376 | (let ((action (string->symbol arg))) | |
1377 | (alist-cons 'action action result))) | |
1378 | (else | |
1379 | (let ((hint (string-closest arg actions #:threshold 3))) | |
1380 | (report-error (G_ "~a: unknown action~%") arg) | |
1381 | (when hint | |
1382 | (display-hint | |
1383 | (format #f (G_ "Did you mean @code{~a}?~%") hint))) | |
1384 | (exit 1))))) | |
523e4896 | 1385 | |
72b9d60d LC |
1386 | (define (match-pair car) |
1387 | ;; Return a procedure that matches a pair with CAR. | |
1388 | (match-lambda | |
d6c3267a LC |
1389 | ((head . tail) |
1390 | (and (eq? car head) tail)) | |
1391 | (_ #f))) | |
72b9d60d LC |
1392 | |
1393 | (define (option-arguments opts) | |
1394 | ;; Extract the plain arguments from OPTS. | |
1395 | (let* ((args (reverse (filter-map (match-pair 'argument) opts))) | |
1396 | (count (length args)) | |
5a72ddf1 MO |
1397 | (action (assoc-ref opts 'action)) |
1398 | (expr (assoc-ref opts 'expression))) | |
72b9d60d | 1399 | (define (fail) |
69daee23 | 1400 | (leave (G_ "wrong number of arguments for action '~a'~%") |
72b9d60d LC |
1401 | action)) |
1402 | ||
d89e0990 LC |
1403 | (unless action |
1404 | (format (current-error-port) | |
69daee23 | 1405 | (G_ "guix system: missing command name~%")) |
d89e0990 | 1406 | (format (current-error-port) |
69daee23 | 1407 | (G_ "Try 'guix system --help' for more information.~%")) |
d89e0990 LC |
1408 | (exit 1)) |
1409 | ||
72b9d60d | 1410 | (case action |
e74baa12 MO |
1411 | ((build container vm vm-image image disk-image docker-image |
1412 | reconfigure) | |
5a72ddf1 MO |
1413 | (unless (or (= count 1) |
1414 | (and expr (= count 0))) | |
72b9d60d LC |
1415 | (fail))) |
1416 | ((init) | |
1417 | (unless (= count 2) | |
1418 | (fail)))) | |
1419 | args)) | |
1420 | ||
523e4896 | 1421 | (with-error-handling |
b3f21389 LC |
1422 | (let* ((opts (parse-command-line args %options |
1423 | (list %default-options) | |
1424 | #:argument-handler | |
1425 | parse-sub-command)) | |
c79d54fe | 1426 | (args (option-arguments opts)) |
deaab8e3 | 1427 | (command (assoc-ref opts 'action))) |
dc0f74e5 | 1428 | (parameterize ((%graft? (assoc-ref opts 'graft?))) |
898e6d0a | 1429 | (with-status-verbosity (verbosity-level opts) |
dc0f74e5 | 1430 | (process-command command args opts)))))) |
b25937e3 | 1431 | |
8bf92e39 | 1432 | ;;; Local Variables: |
89bbcc80 | 1433 | ;;; eval: (put 'with-store* 'scheme-indent-function 1) |
8bf92e39 LC |
1434 | ;;; End: |
1435 | ||
b25937e3 | 1436 | ;;; system.scm ends here |