guix/scripts/system.scm

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