| blob | 91d151d22bb51ed802b3cf8b4c803ed09b5a66c0 |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
4 ;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com>
5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
6 ;;;
7 ;;; This file is part of GNU Guix.
8 ;;;
9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
10 ;;; under the terms of the GNU General Public License as published by
11 ;;; the Free Software Foundation; either version 3 of the License, or (at
12 ;;; your option) any later version.
13 ;;;
14 ;;; GNU Guix is distributed in the hope that it will be useful, but
15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU General Public License
20 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22 (define-module (guix scripts system)
23 #:use-module (guix config)
24 #:use-module (guix ui)
25 #:use-module (guix store)
26 #:use-module (guix grafts)
27 #:use-module (guix gexp)
28 #:use-module (guix derivations)
29 #:use-module (guix packages)
30 #:use-module (guix utils)
31 #:use-module (guix monads)
32 #:use-module (guix records)
33 #:use-module (guix profiles)
34 #:use-module (guix scripts)
35 #:use-module (guix scripts build)
36 #:use-module (guix graph)
37 #:use-module (guix scripts graph)
38 #:use-module (guix build utils)
39 #:use-module (guix progress)
40 #:use-module ((guix build syscalls) #:select (terminal-columns))
41 #:use-module (gnu build install)
42 #:autoload (gnu build file-systems)
43 (find-partition-by-label find-partition-by-uuid)
44 #:use-module (gnu system)
45 #:use-module (gnu bootloader)
46 #:use-module (gnu system file-systems)
47 #:use-module (gnu system linux-container)
48 #:use-module (gnu system uuid)
49 #:use-module (gnu system vm)
50 #:use-module (gnu services)
51 #:use-module (gnu services shepherd)
52 #:use-module (gnu services herd)
53 #:use-module (srfi srfi-1)
54 #:use-module (srfi srfi-11)
55 #:use-module (srfi srfi-19)
56 #:use-module (srfi srfi-26)
57 #:use-module (srfi srfi-34)
58 #:use-module (srfi srfi-35)
59 #:use-module (srfi srfi-37)
60 #:use-module (ice-9 match)
61 #:use-module (rnrs bytevectors)
62 #:export (guix-system
63 read-operating-system))
65 \f
66 ;;;
67 ;;; Operating system declaration.
68 ;;;
70 (define %user-module
71 ;; Module in which the machine description file is loaded.
72 (make-user-module '((gnu system)
73 (gnu services)
74 (gnu system shadow))))
76 (define (read-operating-system file)
77 "Read the operating-system declaration from FILE and return it."
78 (load* file %user-module))
80 \f
81 ;;;
82 ;;; Installation.
83 ;;;
85 (define-syntax-rule (save-load-path-excursion body ...)
86 "Save the current values of '%load-path' and '%load-compiled-path', run
87 BODY..., and restore them."
88 (let ((path %load-path)
89 (cpath %load-compiled-path))
90 (dynamic-wind
91 (const #t)
92 (lambda ()
93 body ...)
94 (lambda ()
95 (set! %load-path path)
96 (set! %load-compiled-path cpath)))))
98 (define-syntax-rule (save-environment-excursion body ...)
99 "Save the current environment variables, run BODY..., and restore them."
100 (let ((env (environ)))
101 (dynamic-wind
102 (const #t)
103 (lambda ()
104 body ...)
105 (lambda ()
106 (environ env)))))
108 (define topologically-sorted*
109 (store-lift topologically-sorted))
112 (define* (copy-item item references target
113 #:key (log-port (current-error-port)))
114 "Copy ITEM to the store under root directory TARGET and register it with
115 REFERENCES as its set of references."
116 (let ((dest (string-append target item))
117 (state (string-append target "/var/guix")))
118 (format log-port "copying '~a'...~%" item)
120 ;; Remove DEST if it exists to make sure that (1) we do not fail badly
121 ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
122 ;; (2) we end up with the right contents.
123 (when (file-exists? dest)
124 (delete-file-recursively dest))
126 (copy-recursively item dest
127 #:log (%make-void-port "w"))
129 ;; Register ITEM; as a side-effect, it resets timestamps, etc.
130 ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
131 ;; reproducing the user's current settings; see
132 ;; <http://bugs.gnu.org/18049>.
133 (unless (register-path item
134 #:prefix target
135 #:state-directory state
136 #:references references)
137 (leave (G_ "failed to register '~a' under '~a'~%")
138 item target))))
140 (define* (copy-closure item target
141 #:key (log-port (current-error-port)))
142 "Copy ITEM and all its dependencies to the store under root directory
143 TARGET, and register them."
144 (mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
145 (refs (mapm %store-monad references* to-copy)))
146 (define progress-bar
147 (progress-reporter/bar (length to-copy)
148 (format #f (G_ "copying to '~a'...")
149 target)))
151 (call-with-progress-reporter progress-bar
152 (lambda (report)
153 (let ((void (%make-void-port "w")))
154 (for-each (lambda (item refs)
155 (copy-item item refs target #:log-port void)
156 (report))
157 to-copy refs))))
159 (return *unspecified*)))
161 (define* (install-bootloader installer-drv
162 #:key
163 bootcfg bootcfg-file
164 target)
165 "Call INSTALLER-DRV with error handling, in %STORE-MONAD."
166 (with-monad %store-monad
167 (let* ((gc-root (string-append target %gc-roots-directory
168 "/bootcfg"))
169 (temp-gc-root (string-append gc-root ".new"))
170 (install (and installer-drv
171 (derivation->output-path installer-drv)))
172 (bootcfg (derivation->output-path bootcfg)))
173 ;; Prepare the symlink to bootloader config file to make sure that it's
174 ;; a GC root when 'installer-drv' completes (being a bit paranoid.)
175 (switch-symlinks temp-gc-root bootcfg)
177 (unless (false-if-exception
178 (begin
179 (install-boot-config bootcfg bootcfg-file target)
180 (when install
181 (save-load-path-excursion (primitive-load install)))))
182 (delete-file temp-gc-root)
183 (leave (G_ "failed to install bootloader ~a~%") install))
185 ;; Register bootloader config file as a GC root so that its dependencies
186 ;; (background image, font, etc.) are not reclaimed.
187 (rename-file temp-gc-root gc-root)
188 (return #t))))
190 (define* (install os-drv target
191 #:key (log-port (current-output-port))
192 bootloader-installer install-bootloader?
193 bootcfg bootcfg-file)
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 'guix-register' 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 "/")
202 (begin
203 (warning (G_ "initializing the current root file system~%"))
204 (return #t))
205 (begin
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))
216 (chown target 0 0)
217 (warning (G_ "not running as 'root', so \
218 the ownership of '~a' may be incorrect!~%")
219 target))
221 (chmod target #o755)
222 (let ((os-dir (derivation->output-path os-drv))
223 (format (lift format %store-monad))
224 (populate (lift2 populate-root-file-system %store-monad)))
226 (mbegin %store-monad
227 ;; Copy the closure of BOOTCFG, which includes OS-DIR,
228 ;; eventual background image and so on.
229 (maybe-copy
230 (derivation->output-path bootcfg))
232 ;; Create a bunch of additional files.
233 (format log-port "populating '~a'...~%" target)
234 (populate os-dir target)
236 (mwhen install-bootloader?
237 (install-bootloader bootloader-installer
238 #:bootcfg bootcfg
239 #:bootcfg-file bootcfg-file
240 #:target target)))))
242 \f
243 ;;;
244 ;;; Reconfiguration.
245 ;;;
247 (define %system-profile
248 ;; The system profile.
249 (string-append %state-directory "/profiles/system"))
251 (define-syntax-rule (with-shepherd-error-handling mbody ...)
252 "Catch and report Shepherd errors that arise when binding MBODY, a monadic
253 expression in %STORE-MONAD."
254 (lambda (store)
255 (catch 'system-error
256 (lambda ()
257 (guard (c ((shepherd-error? c)
258 (values (report-shepherd-error c) store)))
259 (values (run-with-store store (begin mbody ...))
260 store)))
261 (lambda (key proc format-string format-args errno . rest)
262 (warning (G_ "while talking to shepherd: ~a~%")
263 (apply format #f format-string format-args))
264 (values #f store)))))
266 (define (report-shepherd-error error)
267 "Report ERROR, a '&shepherd-error' error condition object."
268 (cond ((service-not-found-error? error)
269 (report-error (G_ "service '~a' could not be found~%")
270 (service-not-found-error-service error)))
271 ((action-not-found-error? error)
272 (report-error (G_ "service '~a' does not have an action '~a'~%")
273 (action-not-found-error-service error)
274 (action-not-found-error-action error)))
275 ((action-exception-error? error)
276 (report-error (G_ "exception caught while executing '~a' \
277 on service '~a':~%")
278 (action-exception-error-action error)
279 (action-exception-error-service error))
280 (print-exception (current-error-port) #f
281 (action-exception-error-key error)
282 (action-exception-error-arguments error)))
283 ((unknown-shepherd-error? error)
284 (report-error (G_ "something went wrong: ~s~%")
285 (unknown-shepherd-error-sexp error)))
286 ((shepherd-error? error)
287 (report-error (G_ "shepherd error~%")))
288 ((not error) ;not an error
289 #t)))
291 (define (call-with-service-upgrade-info new-services mproc)
292 "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of
293 names of services to load (upgrade), and the list of names of services to
294 unload."
295 (match (current-services)
296 ((services ...)
297 (let-values (((to-unload to-load)
298 (shepherd-service-upgrade services new-services)))
299 (mproc to-load
300 (map (compose first live-service-provision)
301 to-unload))))
302 (#f
303 (with-monad %store-monad
304 (warning (G_ "failed to obtain list of shepherd services~%"))
305 (return #f)))))
307 (define (upgrade-shepherd-services os)
308 "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
309 services specified in OS and not currently running.
311 This is currently very conservative in that it does not stop or unload any
312 running service. Unloading or stopping the wrong service ('udev', say) could
313 bring the system down."
314 (define new-services
315 (service-value
316 (fold-services (operating-system-services os)
317 #:target-type shepherd-root-service-type)))
319 ;; Arrange to simply emit a warning if the service upgrade fails.
320 (with-shepherd-error-handling
321 (call-with-service-upgrade-info new-services
322 (lambda (to-load to-unload)
323 (for-each (lambda (unload)
324 (info (G_ "unloading service '~a'...~%") unload)
325 (unload-service unload))
326 to-unload)
328 (with-monad %store-monad
329 (munless (null? to-load)
330 (let ((to-load-names (map shepherd-service-canonical-name to-load))
331 (to-start (filter shepherd-service-auto-start? to-load)))
332 (info (G_ "loading new services:~{ ~a~}...~%") to-load-names)
333 (mlet %store-monad ((files (mapm %store-monad shepherd-service-file
334 to-load)))
335 ;; Here we assume that FILES are exactly those that were computed
336 ;; as part of the derivation that built OS, which is normally the
337 ;; case.
338 (load-services (map derivation->output-path files))
340 (for-each start-service
341 (map shepherd-service-canonical-name to-start))
342 (return #t)))))))))
344 (define* (switch-to-system os
345 #:optional (profile %system-profile))
346 "Make a new generation of PROFILE pointing to the directory of OS, switch to
347 it atomically, and then run OS's activation script."
348 (mlet* %store-monad ((drv (operating-system-derivation os))
349 (script (operating-system-activation-script os)))
350 (let* ((system (derivation->output-path drv))
351 (number (+ 1 (generation-number profile)))
352 (generation (generation-file-name profile number)))
353 (switch-symlinks generation system)
354 (switch-symlinks profile generation)
356 (format #t (G_ "activating system...~%"))
358 ;; The activation script may change $PATH, among others, so protect
359 ;; against that.
360 (save-environment-excursion
361 ;; Tell 'activate-current-system' what the new system is.
362 (setenv "GUIX_NEW_SYSTEM" system)
364 ;; The activation script may modify '%load-path' & co., so protect
365 ;; against that. This is necessary to ensure that
366 ;; 'upgrade-shepherd-services' gets to see the right modules when it
367 ;; computes derivations with 'gexp->derivation'.
368 (save-load-path-excursion
369 (primitive-load (derivation->output-path script))))
371 ;; Finally, try to update system services.
372 (upgrade-shepherd-services os))))
374 (define-syntax-rule (unless-file-not-found exp)
375 (catch 'system-error
376 (lambda ()
377 exp)
378 (lambda args
379 (if (= ENOENT (system-error-errno args))
380 #f
381 (apply throw args)))))
383 (define (seconds->string seconds)
384 "Return a string representing the date for SECONDS."
385 (let ((time (make-time time-utc 0 seconds)))
386 (date->string (time-utc->date time)
387 "~Y-~m-~d ~H:~M")))
389 (define* (profile-boot-parameters #:optional (profile %system-profile)
390 (numbers (generation-numbers profile)))
391 "Return a list of 'boot-parameters' for the generations of PROFILE specified by
392 NUMBERS, which is a list of generation numbers."
393 (define (system->boot-parameters system number time)
394 (unless-file-not-found
395 (let* ((params (read-boot-parameters-file system))
396 (label (boot-parameters-label params)))
397 (boot-parameters
398 (inherit params)
399 (label (string-append label " (#"
400 (number->string number) ", "
401 (seconds->string time) ")"))))))
402 (let* ((systems (map (cut generation-file-name profile <>)
403 numbers))
404 (times (map (lambda (system)
405 (unless-file-not-found
406 (stat:mtime (lstat system))))
407 systems)))
408 (filter-map system->boot-parameters systems numbers times)))
410 \f
411 ;;;
412 ;;; Roll-back.
413 ;;;
414 (define (roll-back-system store)
415 "Roll back the system profile to its previous generation. STORE is an open
416 connection to the store."
417 (switch-to-system-generation store "-1"))
419 \f
420 ;;;
421 ;;; Switch generations.
422 ;;;
423 (define (switch-to-system-generation store spec)
424 "Switch the system profile to the generation specified by SPEC, and
425 re-install bootloader with a configuration file that uses the specified system
426 generation as its default entry. STORE is an open connection to the store."
427 (let ((number (relative-generation-spec->number %system-profile spec)))
428 (if number
429 (begin
430 (reinstall-bootloader store number)
431 (switch-to-generation* %system-profile number))
432 (leave (G_ "cannot switch to system generation '~a'~%") spec))))
434 (define* (system-bootloader-name #:optional (system %system-profile))
435 "Return the bootloader name stored in SYSTEM's \"parameters\" file."
436 (let ((params (unless-file-not-found
437 (read-boot-parameters-file system))))
438 (boot-parameters-bootloader-name params)))
440 (define (reinstall-bootloader store number)
441 "Re-install bootloader for existing system profile generation NUMBER.
442 STORE is an open connection to the store."
443 (let* ((generation (generation-file-name %system-profile number))
444 ;; Detect the bootloader used in %system-profile.
445 (bootloader (lookup-bootloader-by-name (system-bootloader-name)))
447 ;; Use the detected bootloader with default configuration.
448 ;; It will be enough to allow the system to boot.
449 (bootloader-config (bootloader-configuration
450 (bootloader bootloader)))
452 ;; Make the specified system generation the default entry.
453 (params (profile-boot-parameters %system-profile (list number)))
454 (old-generations (delv number (generation-numbers %system-profile)))
455 (old-params (profile-boot-parameters
456 %system-profile old-generations))
457 (entries (map boot-parameters->menu-entry params))
458 (old-entries (map boot-parameters->menu-entry old-params)))
459 (run-with-store store
460 (mlet* %store-monad
461 ((bootcfg ((bootloader-configuration-file-generator bootloader)
462 bootloader-config entries
463 #:old-entries old-entries))
464 (bootcfg-file -> (bootloader-configuration-file bootloader))
465 (target -> "/")
466 (drvs -> (list bootcfg)))
467 (mbegin %store-monad
468 (show-what-to-build* drvs)
469 (built-derivations drvs)
470 ;; Only install bootloader configuration file. Thus, no installer is
471 ;; provided here.
472 (install-bootloader #f
473 #:bootcfg bootcfg
474 #:bootcfg-file bootcfg-file
475 #:target target))))))
477 \f
478 ;;;
479 ;;; Graphs.
480 ;;;
482 (define (service-node-label service)
483 "Return a label to represent SERVICE."
484 (let ((type (service-kind service))
485 (value (service-value service)))
486 (string-append (symbol->string (service-type-name type))
487 (cond ((or (number? value) (symbol? value))
488 (string-append " " (object->string value)))
489 ((string? value)
490 (string-append " " value))
491 ((file-system? value)
492 (string-append " " (file-system-mount-point value)))
493 (else
494 "")))))
496 (define (service-node-type services)
497 "Return a node type for SERVICES. Since <service> instances are not
498 self-contained (they express dependencies on service types, not on services),
499 we have to create the 'edges' procedure dynamically as a function of the full
500 list of services."
501 (node-type
502 (name "service")
503 (description "the DAG of services")
504 (identifier (lift1 object-address %store-monad))
505 (label service-node-label)
506 (edges (lift1 (service-back-edges services) %store-monad))))
508 (define (shepherd-service-node-label service)
509 "Return a label for a node representing a <shepherd-service>."
510 (string-join (map symbol->string (shepherd-service-provision service))))
512 (define (shepherd-service-node-type services)
513 "Return a node type for SERVICES, a list of <shepherd-service>."
514 (node-type
515 (name "shepherd-service")
516 (description "the dependency graph of shepherd services")
517 (identifier (lift1 shepherd-service-node-label %store-monad))
518 (label shepherd-service-node-label)
519 (edges (lift1 (shepherd-service-back-edges services) %store-monad))))
521 \f
522 ;;;
523 ;;; Generations.
524 ;;;
526 (define* (display-system-generation number
527 #:optional (profile %system-profile))
528 "Display a summary of system generation NUMBER in a human-readable format."
529 (unless (zero? number)
530 (let* ((generation (generation-file-name profile number))
531 (params (read-boot-parameters-file generation))
532 (label (boot-parameters-label params))
533 (bootloader-name (boot-parameters-bootloader-name params))
534 (root (boot-parameters-root-device params))
535 (root-device (if (bytevector? root)
536 (uuid->string root)
537 root))
538 (kernel (boot-parameters-kernel params)))
539 (display-generation profile number)
540 (format #t (G_ " file name: ~a~%") generation)
541 (format #t (G_ " canonical file name: ~a~%") (readlink* generation))
542 ;; TRANSLATORS: Please preserve the two-space indentation.
543 (format #t (G_ " label: ~a~%") label)
544 (format #t (G_ " bootloader: ~a~%") bootloader-name)
545 (format #t (G_ " root device: ~a~%")
546 (if (uuid? root-device)
547 (uuid->string root-device)
548 root-device))
549 (format #t (G_ " kernel: ~a~%") kernel))))
551 (define* (list-generations pattern #:optional (profile %system-profile))
552 "Display in a human-readable format all the system generations matching
553 PATTERN, a string. When PATTERN is #f, display all the system generations."
554 (cond ((not (file-exists? profile)) ; XXX: race condition
555 (raise (condition (&profile-not-found-error
556 (profile profile)))))
557 ((string-null? pattern)
558 (for-each display-system-generation (profile-generations profile)))
559 ((matching-generations pattern profile)
560 =>
561 (lambda (numbers)
562 (if (null-list? numbers)
563 (exit 1)
564 (leave-on-EPIPE
565 (for-each display-system-generation numbers)))))
566 (else
567 (leave (G_ "invalid syntax: ~a~%") pattern))))
569 \f
570 ;;;
571 ;;; File system declaration checks.
572 ;;;
574 (define (check-file-system-availability file-systems)
575 "Check whether the UUIDs or partition labels that FILE-SYSTEMS refer to, if
576 any, are available. Raise an error if they're not."
577 (define relevant
578 (filter (lambda (fs)
579 (and (file-system-mount? fs)
580 (not (string=? "tmpfs" (file-system-type fs)))
581 (not (memq 'bind-mount (file-system-flags fs)))))
582 file-systems))
584 (define labeled
585 (filter (lambda (fs)
586 (eq? (file-system-title fs) 'label))
587 relevant))
589 (define uuid
590 (filter (lambda (fs)
591 (eq? (file-system-title fs) 'uuid))
592 relevant))
594 (define fail? #f)
596 (define (file-system-location* fs)
597 (location->string
598 (source-properties->location
599 (file-system-location fs))))
601 (let-syntax ((error (syntax-rules ()
602 ((_ args ...)
603 (begin
604 (set! fail? #t)
605 (format (current-error-port)
606 args ...))))))
607 (for-each (lambda (fs)
608 (unless (find-partition-by-label (file-system-device fs))
609 (error (G_ "~a: error: file system with label '~a' not found~%")
610 (file-system-location* fs)
611 (file-system-device fs))))
612 labeled)
613 (for-each (lambda (fs)
614 (unless (find-partition-by-uuid (file-system-device fs))
615 (error (G_ "~a: error: file system with UUID '~a' not found~%")
616 (file-system-location* fs)
617 (uuid->string (file-system-device fs)))))
618 uuid)
620 (when fail?
621 ;; Better be safe than sorry.
622 (exit 1))))
624 \f
625 ;;;
626 ;;; Action.
627 ;;;
629 (define* (system-derivation-for-action os action
630 #:key image-size file-system-type
631 full-boot? mappings)
632 "Return as a monadic value the derivation for OS according to ACTION."
633 (case action
634 ((build init reconfigure)
635 (operating-system-derivation os))
636 ((container)
637 (container-script os #:mappings mappings))
638 ((vm-image)
639 (system-qemu-image os #:disk-image-size image-size))
640 ((vm)
641 (system-qemu-image/shared-store-script os
642 #:full-boot? full-boot?
643 #:disk-image-size
644 (if full-boot?
645 image-size
646 (* 70 (expt 2 20)))
647 #:mappings mappings))
648 ((disk-image)
649 (system-disk-image os
650 #:name (match file-system-type
651 ("iso9660" "image.iso")
652 (_ "disk-image"))
653 #:disk-image-size image-size
654 #:file-system-type file-system-type))))
656 (define (maybe-suggest-running-guix-pull)
657 "Suggest running 'guix pull' if this has never been done before."
658 ;; The reason for this is that the 'guix' binding that we see here comes
659 ;; from either ~/.config/latest or, if it's missing, from the
660 ;; globally-installed Guix, which is necessarily older. See
661 ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for
662 ;; a discussion.
663 (define latest
664 (string-append (config-directory) "/latest"))
666 (unless (file-exists? latest)
667 (warning (G_ "~a not found: 'guix pull' was never run~%") latest)
668 (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%"))
669 (warning (G_ "Failing to do that may downgrade your system!~%"))))
671 (define (bootloader-installer-derivation installer
672 bootloader device target)
673 "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE
674 and TARGET arguments."
675 (with-monad %store-monad
676 (gexp->file "bootloader-installer"
677 (with-imported-modules '((guix build utils))
678 #~(begin
679 (use-modules (guix build utils))
680 (#$installer #$bootloader #$device #$target))))))
682 (define* (perform-action action os
683 #:key install-bootloader?
684 dry-run? derivations-only?
685 use-substitutes? bootloader-target target
686 image-size file-system-type full-boot?
687 (mappings '())
688 (gc-root #f))
689 "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install
690 bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
691 target root directory; IMAGE-SIZE is the size of the image to be built, for
692 the 'vm-image' and 'disk-image' actions. The root filesystem is created as a
693 FILE-SYSTEM-TYPE filesystem. FULL-BOOT? is used for the 'vm' action; it
694 determines whether to boot directly to the kernel or to the bootloader.
696 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
697 building anything.
699 When GC-ROOT is a path, also make that path an indirect root of the build
700 output when building a system derivation, such as a disk image."
701 (define println
702 (cut format #t "~a~%" <>))
704 (when (eq? action 'reconfigure)
705 (maybe-suggest-running-guix-pull))
707 ;; Check whether the declared file systems exist. This is better than
708 ;; instantiating a broken configuration. Assume that we can only check if
709 ;; running as root.
710 (when (and (memq action '(init reconfigure))
711 (zero? (getuid)))
712 (check-file-system-availability (operating-system-file-systems os)))
714 (mlet* %store-monad
715 ((sys (system-derivation-for-action os action
716 #:file-system-type file-system-type
717 #:image-size image-size
718 #:full-boot? full-boot?
719 #:mappings mappings))
720 (bootloader -> (bootloader-configuration-bootloader
721 (operating-system-bootloader os)))
722 (bootloader-package
723 (let ((package (bootloader-package bootloader)))
724 (if package
725 (package->derivation package)
726 (return #f))))
727 (bootcfg (if (eq? 'container action)
728 (return #f)
729 (operating-system-bootcfg
730 os
731 (if (eq? 'init action)
732 '()
733 (map boot-parameters->menu-entry
734 (profile-boot-parameters))))))
735 (bootcfg-file -> (bootloader-configuration-file bootloader))
736 (bootloader-installer
737 (let ((installer (bootloader-installer bootloader))
738 (target (or target "/")))
739 (bootloader-installer-derivation installer
740 bootloader-package
741 bootloader-target target)))
743 ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
744 ;; --no-bootloader is passed, because we then use it as a GC root.
745 ;; See <http://bugs.gnu.org/21068>.
746 (drvs -> (if (memq action '(init reconfigure))
747 (if (and install-bootloader? bootloader-package)
748 (list sys bootcfg
749 bootloader-package
750 bootloader-installer)
751 (list sys bootcfg))
752 (list sys)))
753 (% (if derivations-only?
754 (return (for-each (compose println derivation-file-name)
755 drvs))
756 (maybe-build drvs #:dry-run? dry-run?
757 #:use-substitutes? use-substitutes?))))
759 (if (or dry-run? derivations-only?)
760 (return #f)
761 (begin
762 (for-each (compose println derivation->output-path)
763 drvs)
765 (case action
766 ((reconfigure)
767 (mbegin %store-monad
768 (switch-to-system os)
769 (mwhen install-bootloader?
770 (install-bootloader bootloader-installer
771 #:bootcfg bootcfg
772 #:bootcfg-file bootcfg-file
773 #:target "/"))))
774 ((init)
775 (newline)
776 (format #t (G_ "initializing operating system under '~a'...~%")
777 target)
778 (install sys (canonicalize-path target)
779 #:install-bootloader? install-bootloader?
780 #:bootcfg bootcfg
781 #:bootcfg-file bootcfg-file
782 #:bootloader-installer bootloader-installer))
783 (else
784 ;; All we had to do was to build SYS and maybe register an
785 ;; indirect GC root.
786 (let ((output (derivation->output-path sys)))
787 (mbegin %store-monad
788 (mwhen gc-root
789 (register-root* (list output) gc-root))
790 (return output)))))))))
792 (define (export-extension-graph os port)
793 "Export the service extension graph of OS to PORT."
794 (let* ((services (operating-system-services os))
795 (system (find (lambda (service)
796 (eq? (service-kind service) system-service-type))
797 services)))
798 (export-graph (list system) (current-output-port)
799 #:node-type (service-node-type services)
800 #:reverse-edges? #t)))
802 (define (export-shepherd-graph os port)
803 "Export the graph of shepherd services of OS to PORT."
804 (let* ((services (operating-system-services os))
805 (pid1 (fold-services services
806 #:target-type shepherd-root-service-type))
807 (shepherds (service-value pid1)) ;list of <shepherd-service>
808 (sinks (filter (lambda (service)
809 (null? (shepherd-service-requirement service)))
810 shepherds)))
811 (export-graph sinks (current-output-port)
812 #:node-type (shepherd-service-node-type shepherds)
813 #:reverse-edges? #t)))
815 \f
816 ;;;
817 ;;; Options.
818 ;;;
820 (define (show-help)
821 (display (G_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE]
822 Build the operating system declared in FILE according to ACTION.
823 Some ACTIONS support additional ARGS.\n"))
824 (newline)
825 (display (G_ "The valid values for ACTION are:\n"))
826 (newline)
827 (display (G_ "\
828 search search for existing service types\n"))
829 (display (G_ "\
830 reconfigure switch to a new operating system configuration\n"))
831 (display (G_ "\
832 roll-back switch to the previous operating system configuration\n"))
833 (display (G_ "\
834 switch-generation switch to an existing operating system configuration\n"))
835 (display (G_ "\
836 list-generations list the system generations\n"))
837 (display (G_ "\
838 build build the operating system without installing anything\n"))
839 (display (G_ "\
840 container build a container that shares the host's store\n"))
841 (display (G_ "\
842 vm build a virtual machine image that shares the host's store\n"))
843 (display (G_ "\
844 vm-image build a freestanding virtual machine image\n"))
845 (display (G_ "\
846 disk-image build a disk image, suitable for a USB stick\n"))
847 (display (G_ "\
848 init initialize a root file system to run GNU\n"))
849 (display (G_ "\
850 extension-graph emit the service extension graph in Dot format\n"))
851 (display (G_ "\
852 shepherd-graph emit the graph of shepherd services in Dot format\n"))
854 (show-build-options-help)
855 (display (G_ "
856 -d, --derivation return the derivation of the given system"))
857 (display (G_ "
858 --on-error=STRATEGY
859 apply STRATEGY when an error occurs while reading FILE"))
860 (display (G_ "
861 --file-system-type=TYPE
862 for 'disk-image', produce a root file system of TYPE
863 (one of 'ext4', 'iso9660')"))
864 (display (G_ "
865 --image-size=SIZE for 'vm-image', produce an image of SIZE"))
866 (display (G_ "
867 --no-bootloader for 'init', do not install a bootloader"))
868 (display (G_ "
869 --share=SPEC for 'vm', share host file system according to SPEC"))
870 (display (G_ "
871 -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container',
872 and 'build', make FILE a symlink to the result, and
873 register it as a garbage collector root"))
874 (display (G_ "
875 --expose=SPEC for 'vm', expose host file system according to SPEC"))
876 (display (G_ "
877 --full-boot for 'vm', make a full boot sequence"))
878 (newline)
879 (display (G_ "
880 -h, --help display this help and exit"))
881 (display (G_ "
882 -V, --version display version information and exit"))
883 (newline)
884 (show-bug-report-information))
886 (define %options
887 ;; Specifications of the command-line options.
888 (cons* (option '(#\h "help") #f #f
889 (lambda args
890 (show-help)
891 (exit 0)))
892 (option '(#\V "version") #f #f
893 (lambda args
894 (show-version-and-exit "guix system")))
895 (option '(#\d "derivation") #f #f
896 (lambda (opt name arg result)
897 (alist-cons 'derivations-only? #t result)))
898 (option '("on-error") #t #f
899 (lambda (opt name arg result)
900 (alist-cons 'on-error (string->symbol arg)
901 result)))
902 (option '(#\t "file-system-type") #t #f
903 (lambda (opt name arg result)
904 (alist-cons 'file-system-type arg
905 result)))
906 (option '("image-size") #t #f
907 (lambda (opt name arg result)
908 (alist-cons 'image-size (size->number arg)
909 result)))
910 (option '("no-bootloader" "no-grub") #f #f
911 (lambda (opt name arg result)
912 (alist-cons 'install-bootloader? #f result)))
913 (option '("full-boot") #f #f
914 (lambda (opt name arg result)
915 (alist-cons 'full-boot? #t result)))
917 (option '("share") #t #f
918 (lambda (opt name arg result)
919 (alist-cons 'file-system-mapping
920 (specification->file-system-mapping arg #t)
921 result)))
922 (option '("expose") #t #f
923 (lambda (opt name arg result)
924 (alist-cons 'file-system-mapping
925 (specification->file-system-mapping arg #f)
926 result)))
928 (option '(#\n "dry-run") #f #f
929 (lambda (opt name arg result)
930 (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
931 (option '(#\s "system") #t #f
932 (lambda (opt name arg result)
933 (alist-cons 'system arg
934 (alist-delete 'system result eq?))))
935 (option '(#\r "root") #t #f
936 (lambda (opt name arg result)
937 (alist-cons 'gc-root arg result)))
938 %standard-build-options))
940 (define %default-options
941 ;; Alist of default option values.
942 `((system . ,(%current-system))
943 (substitutes? . #t)
944 (graft? . #t)
945 (build-hook? . #t)
946 (verbosity . 0)
947 (file-system-type . "ext4")
948 (image-size . guess)
949 (install-bootloader? . #t)))
951 \f
952 ;;;
953 ;;; Entry point.
954 ;;;
956 (define (process-action action args opts)
957 "Process ACTION, a sub-command, with the arguments are listed in ARGS.
958 ACTION must be one of the sub-commands that takes an operating system
959 declaration as an argument (a file name.) OPTS is the raw alist of options
960 resulting from command-line parsing."
961 (let* ((file (match args
962 (() #f)
963 ((x . _) x)))
964 (system (assoc-ref opts 'system))
965 (os (if file
966 (load* file %user-module
967 #:on-error (assoc-ref opts 'on-error))
968 (leave (G_ "no configuration file specified~%"))))
970 (dry? (assoc-ref opts 'dry-run?))
971 (bootloader? (assoc-ref opts 'install-bootloader?))
972 (target (match args
973 ((first second) second)
974 (_ #f)))
975 (bootloader-target
976 (and bootloader?
977 (bootloader-configuration-target
978 (operating-system-bootloader os)))))
980 (with-store store
981 (set-build-options-from-command-line store opts)
983 (run-with-store store
984 (mbegin %store-monad
985 (set-guile-for-build (default-guile))
986 (case action
987 ((extension-graph)
988 (export-extension-graph os (current-output-port)))
989 ((shepherd-graph)
990 (export-shepherd-graph os (current-output-port)))
991 (else
992 (unless (memq action '(build init))
993 (warn-about-old-distro #:suggested-command
994 "guix system reconfigure"))
996 (perform-action action os
997 #:dry-run? dry?
998 #:derivations-only? (assoc-ref opts
999 'derivations-only?)
1000 #:use-substitutes? (assoc-ref opts 'substitutes?)
1001 #:file-system-type (assoc-ref opts 'file-system-type)
1002 #:image-size (assoc-ref opts 'image-size)
1003 #:full-boot? (assoc-ref opts 'full-boot?)
1004 #:mappings (filter-map (match-lambda
1005 (('file-system-mapping . m)
1006 m)
1007 (_ #f))
1008 opts)
1009 #:install-bootloader? bootloader?
1010 #:target target
1011 #:bootloader-target bootloader-target
1012 #:gc-root (assoc-ref opts 'gc-root)))))
1013 #:system system))))
1015 (define (resolve-subcommand name)
1016 (let ((module (resolve-interface
1017 `(guix scripts system ,(string->symbol name))))
1018 (proc (string->symbol (string-append "guix-system-" name))))
1019 (module-ref module proc)))
1021 (define (process-command command args opts)
1022 "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its
1023 argument list and OPTS is the option alist."
1024 (case command
1025 ;; The following commands do not need to use the store, and they do not need
1026 ;; an operating system configuration file.
1027 ((list-generations)
1028 (let ((pattern (match args
1029 (() "")
1030 ((pattern) pattern)
1031 (x (leave (G_ "wrong number of arguments~%"))))))
1032 (list-generations pattern)))
1033 ((search)
1034 (apply (resolve-subcommand "search") args))
1035 ;; The following commands need to use the store, but they do not need an
1036 ;; operating system configuration file.
1037 ((switch-generation)
1038 (let ((pattern (match args
1039 ((pattern) pattern)
1040 (x (leave (G_ "wrong number of arguments~%"))))))
1041 (with-store store
1042 (set-build-options-from-command-line store opts)
1043 (switch-to-system-generation store pattern))))
1044 ((roll-back)
1045 (let ((pattern (match args
1046 (() "")
1047 (x (leave (G_ "wrong number of arguments~%"))))))
1048 (with-store store
1049 (set-build-options-from-command-line store opts)
1050 (roll-back-system store))))
1051 ;; The following commands need to use the store, and they also
1052 ;; need an operating system configuration file.
1053 (else (process-action command args opts))))
1055 (define (guix-system . args)
1056 (define (parse-sub-command arg result)
1057 ;; Parse sub-command ARG and augment RESULT accordingly.
1058 (if (assoc-ref result 'action)
1059 (alist-cons 'argument arg result)
1060 (let ((action (string->symbol arg)))
1061 (case action
1062 ((build container vm vm-image disk-image reconfigure init
1063 extension-graph shepherd-graph list-generations roll-back
1064 switch-generation search)
1065 (alist-cons 'action action result))
1066 (else (leave (G_ "~a: unknown action~%") action))))))
1068 (define (match-pair car)
1069 ;; Return a procedure that matches a pair with CAR.
1070 (match-lambda
1071 ((head . tail)
1072 (and (eq? car head) tail))
1073 (_ #f)))
1075 (define (option-arguments opts)
1076 ;; Extract the plain arguments from OPTS.
1077 (let* ((args (reverse (filter-map (match-pair 'argument) opts)))
1078 (count (length args))
1079 (action (assoc-ref opts 'action)))
1080 (define (fail)
1081 (leave (G_ "wrong number of arguments for action '~a'~%")
1082 action))
1084 (unless action
1085 (format (current-error-port)
1086 (G_ "guix system: missing command name~%"))
1087 (format (current-error-port)
1088 (G_ "Try 'guix system --help' for more information.~%"))
1089 (exit 1))
1091 (case action
1092 ((build container vm vm-image disk-image reconfigure)
1093 (unless (= count 1)
1094 (fail)))
1095 ((init)
1096 (unless (= count 2)
1097 (fail))))
1098 args))
1100 (with-error-handling
1101 (let* ((opts (parse-command-line args %options
1102 (list %default-options)
1103 #:argument-handler
1104 parse-sub-command))
1105 (args (option-arguments opts))
1106 (command (assoc-ref opts 'action)))
1107 (parameterize ((%graft? (assoc-ref opts 'graft?))
1108 (current-terminal-columns (terminal-columns)))
1109 (process-command command args opts)))))
1111 ;;; Local Variables:
1112 ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
1113 ;;; End:
1115 ;;; system.scm ends here