1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
4 ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
5 ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
6 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
7 ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
8 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
9 ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
10 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
12 ;;; This file is part of GNU Guix.
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.
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.
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/>.
27 (define-module (guix scripts system)
28 #:use-module (guix config)
29 #:use-module (guix ui)
30 #:use-module ((guix status) #:select (with-status-verbosity))
31 #:use-module (guix store)
32 #:autoload (guix store database) (register-path)
33 #:use-module (guix describe)
34 #:use-module (guix grafts)
35 #:use-module (guix gexp)
36 #:use-module (guix derivations)
37 #:use-module (guix packages)
38 #:use-module (guix utils)
39 #:use-module (guix monads)
40 #:use-module (guix records)
41 #:use-module (guix profiles)
42 #:use-module (guix scripts)
43 #:use-module (guix channels)
44 #:use-module (guix scripts build)
45 #:autoload (guix scripts package) (delete-generations
46 delete-matching-generations)
47 #:autoload (guix scripts pull) (channel-commit-hyperlink)
48 #:use-module (guix graph)
49 #:use-module (guix scripts graph)
50 #:use-module (guix scripts system reconfigure)
51 #:use-module (guix build utils)
52 #:use-module (guix progress)
53 #:use-module ((guix build syscalls) #:select (terminal-columns))
54 #:use-module (gnu build install)
55 #:autoload (gnu build file-systems)
56 (find-partition-by-label find-partition-by-uuid)
57 #:autoload (gnu build linux-modules)
58 (device-module-aliases matching-modules)
59 #:use-module (gnu system linux-initrd)
60 #:use-module (gnu image)
61 #:use-module (gnu system)
62 #:use-module (gnu bootloader)
63 #:use-module (gnu system file-systems)
64 #:use-module (gnu system image)
65 #:use-module (gnu system mapped-devices)
66 #:use-module (gnu system linux-container)
67 #:use-module (gnu system uuid)
68 #:use-module (gnu system vm)
69 #:use-module (gnu services)
70 #:use-module (gnu services shepherd)
71 #:use-module (gnu services herd)
72 #:use-module (srfi srfi-1)
73 #:use-module (srfi srfi-11)
74 #:use-module (srfi srfi-19)
75 #:use-module (srfi srfi-26)
76 #:use-module (srfi srfi-34)
77 #:use-module (srfi srfi-35)
78 #:use-module (srfi srfi-37)
79 #:use-module (ice-9 format)
80 #:use-module (ice-9 match)
81 #:use-module (rnrs bytevectors)
83 read-operating-system))
87 ;;; Operating system declaration.
91 ;; Module in which the machine description file is loaded.
92 (make-user-module '((gnu system)
94 (gnu system shadow))))
96 (define (read-operating-system file)
97 "Read the operating-system declaration from FILE and return it."
98 (load* file %user-module))
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))
115 (set! %load-path path)
116 (set! %load-compiled-path cpath)))))
118 (define-syntax-rule (save-environment-excursion body ...)
119 "Save the current environment variables, run BODY..., and restore them."
120 (let ((env (environ)))
128 (define topologically-sorted*
129 (store-lift topologically-sorted))
132 (define* (copy-item item references target
133 #:key (log-port (current-error-port)))
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)
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.
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)))
148 (delete-file-recursively dest))
150 (copy-recursively item dest
151 #:log (%make-void-port "w"))
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
159 #:state-directory state
160 #:references references)
161 (leave (G_ "failed to register '~a' under '~a'~%")
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."
168 (mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
169 (refs (mapm %store-monad references* to-copy))
170 (info (mapm %store-monad query-path-info*
172 (append to-copy (concatenate refs)))))
173 (size -> (reduce + 0 (map path-info-nar-size info))))
175 (progress-reporter/bar (length to-copy)
176 (format #f (G_ "copying to '~a'...")
179 (check-available-space size target)
181 (call-with-progress-reporter progress-bar
183 (let ((void (%make-void-port "w")))
184 (for-each (lambda (item refs)
185 (copy-item item refs target #:log-port void)
189 (return *unspecified*)))
191 (define* (install os-drv target
192 #:key (log-port (current-output-port))
193 install-bootloader? bootloader bootcfg)
194 "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to
195 directory TARGET. TARGET must be an absolute directory name since that's what
196 'register-path' expects.
198 When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG."
199 (define (maybe-copy to-copy)
200 (with-monad %store-monad
201 (if (string=? target "/")
203 (warning (G_ "initializing the current root file system~%"))
206 ;; Make sure the target store exists.
207 (mkdir-p (string-append target (%store-prefix)))
209 ;; Copy items to the new store.
210 (copy-closure to-copy target #:log-port log-port)))))
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))
217 (warning (G_ "not running as 'root', so \
218 the ownership of '~a' may be incorrect!~%")
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)))
229 (let ((os-dir (derivation->output-path os-drv))
230 (format (lift format %store-monad))
231 (populate (lift2 populate-root-file-system %store-monad)))
233 (mlet %store-monad ((bootcfg (lower-object bootcfg)))
235 ;; Copy the closure of BOOTCFG, which includes OS-DIR,
236 ;; eventual background image and so on.
237 (maybe-copy (derivation->output-path bootcfg))
239 ;; Create a bunch of additional files.
240 (format log-port "populating '~a'...~%" target)
241 (populate os-dir target)
243 (mwhen install-bootloader?
244 (install-bootloader local-eval bootloader bootcfg
247 (info (G_ "bootloader successfully installed on '~a'~%")
248 (bootloader-configuration-target bootloader))))))))
255 (define %system-profile
256 ;; The system profile.
257 (string-append %state-directory "/profiles/system"))
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."
265 (guard (c ((shepherd-error? c)
266 (values (report-shepherd-error c) store)))
267 (values (run-with-store store (mbegin %store-monad mbody ...))
269 (lambda (key proc format-string format-args errno . rest)
270 (warning (G_ "while talking to shepherd: ~a~%")
271 (apply format #f format-string format-args))
272 (values #f store)))))
274 (define (report-shepherd-error error)
275 "Report ERROR, a '&shepherd-error' error condition object."
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' \
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~%"))))
298 ;; Don't leave users out in the cold and explain what that means and what
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."))))
304 (define-syntax-rule (unless-file-not-found exp)
309 (if (= ENOENT (system-error-errno args))
311 (apply throw args)))))
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)
319 (define* (profile-boot-parameters #:optional (profile %system-profile)
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."
325 (define (system->boot-parameters system number time)
326 (unless-file-not-found
327 (let* ((params (read-boot-parameters-file system))
328 (label (boot-parameters-label params)))
331 (label (string-append label " (#"
332 (number->string number) ", "
333 (seconds->string time) ")"))))))
334 (let* ((systems (map (cut generation-file-name profile <>)
336 (times (map (lambda (system)
337 (unless-file-not-found
338 (stat:mtime (lstat system))))
340 (filter-map system->boot-parameters systems numbers times)))
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"))
353 ;;; Switch generations.
355 (define (switch-to-system-generation store spec)
356 "Switch the system profile to the generation specified by SPEC, and
357 re-install bootloader with a configuration file that uses the specified system
358 generation as its default entry. STORE is an open connection to the store."
359 (let ((number (relative-generation-spec->number %system-profile spec)))
362 (reinstall-bootloader store number)
363 (switch-to-generation* %system-profile number))
364 (leave (G_ "cannot switch to system generation '~a'~%") spec))))
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))))
370 (boot-parameters-bootloader-name params)))
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."
375 (let* ((generation (generation-file-name %system-profile number))
376 ;; Detect the bootloader used in %system-profile.
377 (bootloader (lookup-bootloader-by-name (system-bootloader-name)))
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)))
384 ;; Make the specified system generation the default entry.
385 (params (first (profile-boot-parameters %system-profile
388 (delv number (reverse (generation-numbers %system-profile))))
389 (old-params (profile-boot-parameters
390 %system-profile old-generations))
391 (entries (cons (boot-parameters->menu-entry params)
392 (boot-parameters-bootloader-menu-entries params)))
393 (old-entries (map boot-parameters->menu-entry old-params)))
394 (run-with-store store
396 ((bootcfg (lower-object
397 ((bootloader-configuration-file-generator bootloader)
398 bootloader-config entries
399 #:old-entries old-entries)))
400 (drvs -> (list bootcfg)))
402 (built-derivations drvs)
403 ;; Only install bootloader configuration file.
404 (install-bootloader local-eval bootloader-config bootcfg
405 #:run-installer? #f))))))
412 (define (service-node-label service)
413 "Return a label to represent SERVICE."
414 (let ((type (service-kind service))
415 (value (service-value service)))
416 (string-append (symbol->string (service-type-name type))
417 (cond ((or (number? value) (symbol? value))
418 (string-append " " (object->string value)))
420 (string-append " " value))
421 ((file-system? value)
422 (string-append " " (file-system-mount-point value)))
426 (define (service-node-type services)
427 "Return a node type for SERVICES. Since <service> instances are not
428 self-contained (they express dependencies on service types, not on services),
429 we have to create the 'edges' procedure dynamically as a function of the full
433 (description "the DAG of services")
434 (identifier (lift1 object-address %store-monad))
435 (label service-node-label)
436 (edges (lift1 (service-back-edges services) %store-monad))))
438 (define (shepherd-service-node-label service)
439 "Return a label for a node representing a <shepherd-service>."
440 (string-join (map symbol->string (shepherd-service-provision service))))
442 (define (shepherd-service-node-type services)
443 "Return a node type for SERVICES, a list of <shepherd-service>."
445 (name "shepherd-service")
446 (description "the dependency graph of shepherd services")
447 (identifier (lift1 shepherd-service-node-label %store-monad))
448 (label shepherd-service-node-label)
449 (edges (lift1 (shepherd-service-back-edges services) %store-monad))))
456 (define* (display-system-generation number
457 #:optional (profile %system-profile))
458 "Display a summary of system generation NUMBER in a human-readable format."
459 (define (display-channel channel)
460 (format #t " ~a:~%" (channel-name channel))
461 (format #t (G_ " repository URL: ~a~%") (channel-url channel))
462 (when (channel-branch channel)
463 (format #t (G_ " branch: ~a~%") (channel-branch channel)))
464 (format #t (G_ " commit: ~a~%")
465 (if (supports-hyperlinks?)
466 (channel-commit-hyperlink channel)
467 (channel-commit channel))))
469 (unless (zero? number)
470 (let* ((generation (generation-file-name profile number))
471 (params (read-boot-parameters-file generation))
472 (label (boot-parameters-label params))
473 (bootloader-name (boot-parameters-bootloader-name params))
474 (root (boot-parameters-root-device params))
475 (root-device (if (bytevector? root)
478 (kernel (boot-parameters-kernel params))
479 (multiboot-modules (boot-parameters-multiboot-modules params)))
480 (define-values (channels config-file)
481 (system-provenance generation))
483 (display-generation profile number)
484 (format #t (G_ " file name: ~a~%") generation)
485 (format #t (G_ " canonical file name: ~a~%") (readlink* generation))
486 ;; TRANSLATORS: Please preserve the two-space indentation.
487 (format #t (G_ " label: ~a~%") label)
488 (format #t (G_ " bootloader: ~a~%") bootloader-name)
490 ;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string must
491 ;; be preserved. They denote conditionals, such that the result will
493 ;; root device: UUID: 12345-678
495 ;; root device: label: "my-root"
497 ;; root device: /dev/sda3
498 (format #t (G_ " root device: ~[UUID: ~a~;label: ~s~;~a~]~%")
499 (cond ((uuid? root-device) 0)
500 ((file-system-label? root-device) 1)
502 (file-system-device->string root-device))
504 (format #t (G_ " kernel: ~a~%") kernel)
506 (match multiboot-modules
509 (format #t (G_ " multiboot: ~a~%")
510 (string-join modules "\n "))))
512 (unless (null? channels)
513 ;; TRANSLATORS: Here "channel" is the same terminology as used in
514 ;; "guix describe" and "guix pull --channels".
515 (format #t (G_ " channels:~%"))
516 (for-each display-channel channels))
518 (format #t (G_ " configuration file: ~a~%")
519 (if (supports-hyperlinks?)
520 (file-hyperlink config-file)
523 (define* (list-generations pattern #:optional (profile %system-profile))
524 "Display in a human-readable format all the system generations matching
525 PATTERN, a string. When PATTERN is #f, display all the system generations."
526 (cond ((not (file-exists? profile)) ; XXX: race condition
527 (raise (condition (&profile-not-found-error
528 (profile profile)))))
530 (for-each display-system-generation (profile-generations profile)))
531 ((matching-generations pattern profile)
534 (if (null-list? numbers)
537 (for-each display-system-generation numbers)))))))
541 ;;; File system declaration checks.
544 (define (check-file-system-availability file-systems)
545 "Check whether the UUIDs or partition labels that FILE-SYSTEMS refer to, if
546 any, are available. Raise an error if they're not."
549 (and (file-system-mount? fs)
550 (not (member (file-system-type fs)
551 %pseudo-file-system-types))
552 ;; Don't try to validate network file systems.
553 (not (string-prefix? "nfs" (file-system-type fs)))
554 (not (memq 'bind-mount (file-system-flags fs)))))
559 (file-system-label? (file-system-device fs)))
564 (string? (file-system-device fs)))
569 (uuid? (file-system-device fs)))
574 (define (file-system-location* fs)
575 (and=> (file-system-location fs)
576 source-properties->location))
578 (let-syntax ((error (syntax-rules ()
582 (report-error args ...))))))
583 (for-each (lambda (fs)
586 (stat (file-system-device fs)))
588 (let ((errno (system-error-errno args))
589 (device (file-system-device fs)))
590 (error (file-system-location* fs)
591 (G_ "device '~a' not found: ~a~%")
592 device (strerror errno))
593 (unless (string-prefix? "/" device)
594 (display-hint (format #f (G_ "If '~a' is a file system
595 label, write @code{(file-system-label ~s)} in your @code{device} field.")
598 (for-each (lambda (fs)
599 (let ((label (file-system-label->string
600 (file-system-device fs))))
601 (unless (find-partition-by-label label)
602 (error (file-system-location* fs)
603 (G_ "file system with label '~a' not found~%")
606 (for-each (lambda (fs)
607 (unless (find-partition-by-uuid (file-system-device fs))
608 (error (file-system-location* fs)
609 (G_ "file system with UUID '~a' not found~%")
610 (uuid->string (file-system-device fs)))))
614 ;; Better be safe than sorry.
617 (define (check-mapped-devices os)
618 "Check that each of MAPPED-DEVICES is valid according to the 'check'
619 procedure of its type."
620 (define boot-mapped-devices
621 (operating-system-boot-mapped-devices os))
623 (define (needed-for-boot? md)
624 (memq md boot-mapped-devices))
626 (define initrd-modules
627 (operating-system-initrd-modules os))
629 (for-each (lambda (md)
630 (let ((check (mapped-device-kind-check
631 (mapped-device-type md))))
632 ;; We expect CHECK to raise an exception with a detailed
633 ;; '&message' if something goes wrong.
635 #:needed-for-boot? (needed-for-boot? md)
636 #:initrd-modules initrd-modules)))
637 (operating-system-mapped-devices os)))
639 (define (check-initrd-modules os)
640 "Check that modules needed by 'needed-for-boot' file systems in OS are
641 available in the initrd. Note that mapped devices are responsible for
642 checking this by themselves in their 'check' procedure."
643 (define (file-system-/dev fs)
644 (let ((device (file-system-device fs)))
649 (find-partition-by-uuid device))
650 ((? file-system-label?)
651 (find-partition-by-label (file-system-label->string device))))))
654 (filter file-system-needed-for-boot?
655 (operating-system-file-systems os)))
657 (for-each (lambda (fs)
658 (check-device-initrd-modules (file-system-/dev fs)
659 (operating-system-initrd-modules os)
660 (source-properties->location
661 (file-system-location fs))))
669 (define* (system-derivation-for-action os base-image action
670 #:key image-size file-system-type
671 full-boot? container-shared-network?
673 "Return as a monadic value the derivation for OS according to ACTION."
675 ((build init reconfigure)
676 (operating-system-derivation os))
681 #:shared-network? container-shared-network?))
683 (system-qemu-image os #:disk-image-size image-size))
685 (system-qemu-image/shared-store-script os
686 #:full-boot? full-boot?
691 #:mappings mappings))
696 (inherit (if label (image-with-label base-image label) base-image))
698 (operating-system os)))))
700 (system-docker-image os #:shared-network? container-shared-network?))))
702 (define (maybe-suggest-running-guix-pull)
703 "Suggest running 'guix pull' if this has never been done before."
704 ;; Check whether we're running a 'guix pull'-provided 'guix' command. When
705 ;; 'current-profile' returns #f, we may be running the globally-installed
706 ;; 'guix' and thus run the risk of deploying an older 'guix'. See
707 ;; <https://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html>
708 (unless (or (current-profile) (getenv "GUIX_UNINSTALLED"))
709 (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%"))
710 (warning (G_ "Failing to do that may downgrade your system!~%"))))
712 (define (bootloader-installer-script installer
713 bootloader device target)
714 "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE
715 and TARGET arguments."
716 (scheme-file "bootloader-installer"
717 (with-imported-modules '((gnu build bootloader)
720 (use-modules (gnu build bootloader)
726 (guard (c ((message-condition? c) ;XXX: i18n
727 (format (current-error-port) "error: ~a~%"
728 (condition-message c))
730 (#$installer #$bootloader #$device #$target)
731 (info (G_ "bootloader successfully installed on '~a'~%")
734 (define (local-eval exp)
735 "Evaluate EXP, a G-Expression, in-place."
736 (mlet* %store-monad ((lowered (lower-gexp exp))
737 (_ (built-derivations (lowered-gexp-inputs lowered))))
738 (save-load-path-excursion
739 (set! %load-path (lowered-gexp-load-path lowered))
740 (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
741 (return (primitive-eval (lowered-gexp-sexp lowered))))))
743 (define* (perform-action action os
745 (validate-reconfigure ensure-forward-reconfigure)
749 dry-run? derivations-only?
750 use-substitutes? bootloader-target target
751 image-size file-system-type full-boot? label
752 container-shared-network?
755 "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install
756 bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
757 target root directory; IMAGE-SIZE is the size of the image to be built, for
758 the 'vm-image' and 'disk-image' actions. The root file system is created as a
759 FILE-SYSTEM-TYPE file system. FULL-BOOT? is used for the 'vm' action; it
760 determines whether to boot directly to the kernel or to the bootloader.
761 CONTAINER-SHARED-NETWORK? determines if the container will use a separate
764 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
767 When GC-ROOT is a path, also make that path an indirect root of the build
768 output when building a system derivation, such as a disk image.
770 When SKIP-SAFETY-CHECKS? is true, skip the file system and initrd module
773 (cut format #t "~a~%" <>))
776 (if (eq? 'init action)
778 (map boot-parameters->menu-entry (profile-boot-parameters))))
781 (operating-system-bootloader os))
784 (and (memq action '(init reconfigure))
785 (operating-system-bootcfg os menu-entries)))
787 (when (eq? action 'reconfigure)
788 (maybe-suggest-running-guix-pull)
789 (check-forward-update validate-reconfigure))
791 ;; Check whether the declared file systems exist. This is better than
792 ;; instantiating a broken configuration. Assume that we can only check if
794 (when (and (not skip-safety-checks?)
795 (memq action '(init reconfigure)))
796 (check-mapped-devices os)
797 (when (zero? (getuid))
798 (check-file-system-availability (operating-system-file-systems os))
799 (check-initrd-modules os)))
802 ((target* (current-target-system))
803 (image -> (find-image file-system-type target*))
804 (sys (system-derivation-for-action os image action
806 #:file-system-type file-system-type
807 #:image-size image-size
808 #:full-boot? full-boot?
809 #:container-shared-network? container-shared-network?
810 #:mappings mappings))
812 ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
813 ;; --no-bootloader is passed, because we then use it as a GC root.
814 ;; See <http://bugs.gnu.org/21068>.
815 (drvs (mapm/accumulate-builds lower-object
816 (if (memq action '(init reconfigure))
819 (% (if derivations-only?
820 (return (for-each (compose println derivation-file-name)
822 (built-derivations drvs))))
824 (if (or dry-run? derivations-only?)
827 (for-each (compose println derivation->output-path)
833 (format #t (G_ "activating system...~%"))
835 (switch-to-system local-eval os)
836 (mwhen install-bootloader?
837 (install-bootloader local-eval bootloader bootcfg
838 #:target (or target "/"))
840 (info (G_ "bootloader successfully installed on '~a'~%")
841 (bootloader-configuration-target bootloader))))
842 (with-shepherd-error-handling
843 (upgrade-shepherd-services local-eval os)
844 (return (format #t (G_ "\
845 To complete the upgrade, run 'herd restart SERVICE' to stop,
846 upgrade, and restart each service that was not automatically restarted.\n")))
847 (return (format #t (G_ "\
848 Run 'herd status' to view the list of services on your system.\n"))))))
851 (format #t (G_ "initializing operating system under '~a'...~%")
853 (install sys (canonicalize-path target)
854 #:install-bootloader? install-bootloader?
855 #:bootloader bootloader
858 ;; All we had to do was to build SYS and maybe register an
860 (let ((output (derivation->output-path sys)))
863 (register-root* (list output) gc-root))
864 (return output)))))))))
866 (define (export-extension-graph os port)
867 "Export the service extension graph of OS to PORT."
868 (let* ((services (operating-system-services os))
869 (system (find (lambda (service)
870 (eq? (service-kind service) system-service-type))
872 (export-graph (list system) (current-output-port)
873 #:node-type (service-node-type services)
874 #:reverse-edges? #t)))
876 (define (export-shepherd-graph os port)
877 "Export the graph of shepherd services of OS to PORT."
878 (let* ((services (operating-system-services os))
879 (pid1 (fold-services services
880 #:target-type shepherd-root-service-type))
881 (shepherds (service-value pid1)) ;list of <shepherd-service>
882 (sinks (filter (lambda (service)
883 (null? (shepherd-service-requirement service)))
885 (export-graph sinks (current-output-port)
886 #:node-type (shepherd-service-node-type shepherds)
887 #:reverse-edges? #t)))
895 (display (G_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE]
896 Build the operating system declared in FILE according to ACTION.
897 Some ACTIONS support additional ARGS.\n"))
899 (display (G_ "The valid values for ACTION are:\n"))
902 search search for existing service types\n"))
904 reconfigure switch to a new operating system configuration\n"))
906 roll-back switch to the previous operating system configuration\n"))
908 describe describe the current system\n"))
910 list-generations list the system generations\n"))
912 switch-generation switch to an existing operating system configuration\n"))
914 delete-generations delete old system generations\n"))
916 build build the operating system without installing anything\n"))
918 container build a container that shares the host's store\n"))
920 vm build a virtual machine image that shares the host's store\n"))
922 vm-image build a freestanding virtual machine image\n"))
924 disk-image build a disk image, suitable for a USB stick\n"))
926 docker-image build a Docker image\n"))
928 init initialize a root file system to run GNU\n"))
930 extension-graph emit the service extension graph in Dot format\n"))
932 shepherd-graph emit the graph of shepherd services in Dot format\n"))
934 (show-build-options-help)
936 -d, --derivation return the derivation of the given system"))
938 -e, --expression=EXPR consider the operating-system EXPR evaluates to
939 instead of reading FILE, when applicable"))
941 --allow-downgrades for 'reconfigure', allow downgrades to earlier
945 apply STRATEGY (one of nothing-special, backtrace,
946 or debug) when an error occurs while reading FILE"))
948 --file-system-type=TYPE
949 for 'disk-image', produce a root file system of TYPE
950 (one of 'ext4', 'iso9660')"))
952 --image-size=SIZE for 'vm-image', produce an image of SIZE"))
954 --no-bootloader for 'init', do not install a bootloader"))
956 --label=LABEL for 'disk-image', label disk image with LABEL"))
958 --save-provenance save provenance information"))
960 --share=SPEC for 'vm' and 'container', share host file system with
961 read/write access according to SPEC"))
963 --expose=SPEC for 'vm' and 'container', expose host file system
964 directory as read-only according to SPEC"))
966 -N, --network for 'container', allow containers to access the network"))
968 -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container',
969 and 'build', make FILE a symlink to the result, and
970 register it as a garbage collector root"))
972 --full-boot for 'vm', make a full boot sequence"))
974 --skip-checks skip file system and initrd module safety checks"))
976 --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
978 -v, --verbosity=LEVEL use the given verbosity LEVEL"))
981 -h, --help display this help and exit"))
983 -V, --version display version information and exit"))
985 (show-bug-report-information))
988 ;; Specifications of the command-line options.
989 (cons* (option '(#\h "help") #f #f
993 (option '(#\V "version") #f #f
995 (show-version-and-exit "guix system")))
996 (option '(#\e "expression") #t #f
997 (lambda (opt name arg result)
998 (alist-cons 'expression arg result)))
999 (option '(#\d "derivation") #f #f
1000 (lambda (opt name arg result)
1001 (alist-cons 'derivations-only? #t result)))
1002 (option '("allow-downgrades") #f #f
1003 (lambda (opt name arg result)
1004 (alist-cons 'validate-reconfigure
1005 warn-about-backward-reconfigure
1007 (option '("on-error") #t #f
1008 (lambda (opt name arg result)
1009 (alist-cons 'on-error (string->symbol arg)
1011 (option '(#\t "file-system-type") #t #f
1012 (lambda (opt name arg result)
1013 (alist-cons 'file-system-type arg
1015 (option '("image-size") #t #f
1016 (lambda (opt name arg result)
1017 (alist-cons 'image-size (size->number arg)
1019 (option '(#\N "network") #f #f
1020 (lambda (opt name arg result)
1021 (alist-cons 'container-shared-network? #t result)))
1022 (option '("no-bootloader" "no-grub") #f #f
1023 (lambda (opt name arg result)
1024 (alist-cons 'install-bootloader? #f result)))
1025 (option '("label") #t #f
1026 (lambda (opt name arg result)
1027 (alist-cons 'label arg result)))
1028 (option '("full-boot") #f #f
1029 (lambda (opt name arg result)
1030 (alist-cons 'full-boot? #t result)))
1031 (option '("save-provenance") #f #f
1032 (lambda (opt name arg result)
1033 (alist-cons 'save-provenance? #t result)))
1034 (option '("skip-checks") #f #f
1035 (lambda (opt name arg result)
1036 (alist-cons 'skip-safety-checks? #t result)))
1038 (option '("share") #t #f
1039 (lambda (opt name arg result)
1040 (alist-cons 'file-system-mapping
1041 (specification->file-system-mapping arg #t)
1043 (option '("expose") #t #f
1044 (lambda (opt name arg result)
1045 (alist-cons 'file-system-mapping
1046 (specification->file-system-mapping arg #f)
1049 (option '(#\n "dry-run") #f #f
1050 (lambda (opt name arg result)
1051 (alist-cons 'dry-run? #t result)))
1052 (option '(#\v "verbosity") #t #f
1053 (lambda (opt name arg result)
1054 (let ((level (string->number* arg)))
1055 (alist-cons 'verbosity level
1056 (alist-delete 'verbosity result)))))
1057 (option '(#\s "system") #t #f
1058 (lambda (opt name arg result)
1059 (alist-cons 'system arg
1060 (alist-delete 'system result eq?))))
1061 (option '("target") #t #f
1062 (lambda (opt name arg result)
1063 (alist-cons 'target arg
1064 (alist-delete 'target result eq?))))
1065 (option '(#\r "root") #t #f
1066 (lambda (opt name arg result)
1067 (alist-cons 'gc-root arg result)))
1068 %standard-build-options))
1070 (define %default-options
1071 ;; Alist of default option values.
1072 `((system . ,(%current-system))
1076 (print-build-trace? . #t)
1077 (print-extended-build-trace? . #t)
1078 (multiplexed-build-output? . #t)
1081 (verbosity . #f) ;default
1082 (validate-reconfigure . ,ensure-forward-reconfigure)
1083 (file-system-type . "ext4")
1084 (image-size . guess)
1085 (install-bootloader? . #t)
1088 (define (verbosity-level opts)
1089 "Return the verbosity level based on OPTS, the alist of parsed options."
1090 (or (assoc-ref opts 'verbosity)
1091 (if (eq? (assoc-ref opts 'action) 'build)
1099 (define (process-action action args opts)
1100 "Process ACTION, a sub-command, with the arguments are listed in ARGS.
1101 ACTION must be one of the sub-commands that takes an operating system
1102 declaration as an argument (a file name.) OPTS is the raw alist of options
1103 resulting from command-line parsing."
1104 (define (ensure-operating-system file-or-exp obj)
1105 (unless (operating-system? obj)
1106 (leave (G_ "'~a' does not return an operating system~%")
1110 (define save-provenance?
1111 (or (assoc-ref opts 'save-provenance?)
1112 (memq action '(init reconfigure))))
1114 (let* ((file (match args
1117 (expr (assoc-ref opts 'expression))
1118 (system (assoc-ref opts 'system))
1119 (target (assoc-ref opts 'target))
1120 (transform (if save-provenance?
1121 (cut operating-system-with-provenance <> file)
1124 (ensure-operating-system
1129 (G_ "both file and expression cannot be specified~%")))
1133 (load* file %user-module
1134 #:on-error (assoc-ref opts 'on-error)))
1136 (leave (G_ "no configuration specified~%")))))))
1138 (dry? (assoc-ref opts 'dry-run?))
1139 (bootloader? (assoc-ref opts 'install-bootloader?))
1140 (label (assoc-ref opts 'label))
1141 (target-file (match args
1142 ((first second) second)
1146 (bootloader-configuration-target
1147 (operating-system-bootloader os)))))
1150 (set-build-options-from-command-line store opts)
1152 (with-build-handler (build-notifier #:use-substitutes?
1153 (assoc-ref opts 'substitutes?)
1155 (verbosity-level opts)
1157 (assoc-ref opts 'dry-run?))
1158 (run-with-store store
1159 (mbegin %store-monad
1160 (set-guile-for-build (default-guile))
1163 (export-extension-graph os (current-output-port)))
1165 (export-shepherd-graph os (current-output-port)))
1167 (unless (memq action '(build init))
1168 (warn-about-old-distro #:suggested-command
1169 "guix system reconfigure"))
1171 (perform-action action os
1173 #:derivations-only? (assoc-ref opts
1175 #:use-substitutes? (assoc-ref opts 'substitutes?)
1176 #:skip-safety-checks?
1177 (assoc-ref opts 'skip-safety-checks?)
1178 #:validate-reconfigure
1179 (assoc-ref opts 'validate-reconfigure)
1180 #:file-system-type (assoc-ref opts 'file-system-type)
1181 #:image-size (assoc-ref opts 'image-size)
1182 #:full-boot? (assoc-ref opts 'full-boot?)
1183 #:container-shared-network?
1184 (assoc-ref opts 'container-shared-network?)
1185 #:mappings (filter-map (match-lambda
1186 (('file-system-mapping . m)
1190 #:install-bootloader? bootloader?
1192 #:target target-file
1193 #:bootloader-target bootloader-target
1194 #:gc-root (assoc-ref opts 'gc-root)))))
1197 (warn-about-disk-space)))
1199 (define (resolve-subcommand name)
1200 (let ((module (resolve-interface
1201 `(guix scripts system ,(string->symbol name))))
1202 (proc (string->symbol (string-append "guix-system-" name))))
1203 (module-ref module proc)))
1205 (define (process-command command args opts)
1206 "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its
1207 argument list and OPTS is the option alist."
1208 (define-syntax-rule (with-store* store exp ...)
1210 (set-build-options-from-command-line store opts)
1214 ;; The following commands do not need to use the store, and they do not need
1215 ;; an operating system configuration file.
1217 (let ((pattern (match args
1220 (x (leave (G_ "wrong number of arguments~%"))))))
1221 (list-generations pattern)))
1223 (match (generation-number %system-profile)
1225 (error (G_ "no system generation, nothing to describe~%")))
1227 (display-system-generation generation))))
1229 (apply (resolve-subcommand "search") args))
1230 ;; The following commands need to use the store, but they do not need an
1231 ;; operating system configuration file.
1232 ((delete-generations)
1233 (let ((pattern (match args
1236 (x (leave (G_ "wrong number of arguments~%"))))))
1238 (delete-matching-generations store %system-profile pattern)
1239 (reinstall-bootloader store (generation-number %system-profile)))))
1240 ((switch-generation)
1241 (let ((pattern (match args
1243 (x (leave (G_ "wrong number of arguments~%"))))))
1245 (switch-to-system-generation store pattern))))
1247 (let ((pattern (match args
1249 (x (leave (G_ "wrong number of arguments~%"))))))
1251 (roll-back-system store))))
1252 ;; The following commands need to use the store, and they also
1253 ;; need an operating system configuration file.
1254 (else (process-action command args opts))))
1256 (define-command (guix-system . args)
1257 (synopsis "build and deploy full operating systems")
1259 (define (parse-sub-command arg result)
1260 ;; Parse sub-command ARG and augment RESULT accordingly.
1261 (if (assoc-ref result 'action)
1262 (alist-cons 'argument arg result)
1263 (let ((action (string->symbol arg)))
1265 ((build container vm vm-image disk-image reconfigure init
1266 extension-graph shepherd-graph
1267 list-generations describe
1268 delete-generations roll-back
1269 switch-generation search docker-image)
1270 (alist-cons 'action action result))
1271 (else (leave (G_ "~a: unknown action~%") action))))))
1273 (define (match-pair car)
1274 ;; Return a procedure that matches a pair with CAR.
1277 (and (eq? car head) tail))
1280 (define (option-arguments opts)
1281 ;; Extract the plain arguments from OPTS.
1282 (let* ((args (reverse (filter-map (match-pair 'argument) opts)))
1283 (count (length args))
1284 (action (assoc-ref opts 'action))
1285 (expr (assoc-ref opts 'expression)))
1287 (leave (G_ "wrong number of arguments for action '~a'~%")
1291 (format (current-error-port)
1292 (G_ "guix system: missing command name~%"))
1293 (format (current-error-port)
1294 (G_ "Try 'guix system --help' for more information.~%"))
1298 ((build container vm vm-image disk-image docker-image reconfigure)
1299 (unless (or (= count 1)
1300 (and expr (= count 0)))
1307 (with-error-handling
1308 (let* ((opts (parse-command-line args %options
1309 (list %default-options)
1312 (args (option-arguments opts))
1313 (command (assoc-ref opts 'action)))
1314 (parameterize ((%graft? (assoc-ref opts 'graft?)))
1315 (with-status-verbosity (verbosity-level opts)
1316 (process-command command args opts))))))
1318 ;;; Local Variables:
1319 ;;; eval: (put 'with-store* 'scheme-indent-function 1)
1322 ;;; system.scm ends here