guix/scripts/system.scm

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