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