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