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