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