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