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, 2019 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 (first (profile-boot-parameters %system-profile
 388                                                  (list number))))
 389          (old-generations
 390           (delv number (reverse (generation-numbers %system-profile))))
 391          (old-params (profile-boot-parameters
 392                        %system-profile old-generations))
 393          (entries (cons (boot-parameters->menu-entry params)
 394                         (boot-parameters-bootloader-menu-entries params)))
 395          (old-entries (map boot-parameters->menu-entry old-params)))
 396     (run-with-store store
 397       (mlet* %store-monad
 398           ((bootcfg (lower-object
 399                      ((bootloader-configuration-file-generator bootloader)
 400                       bootloader-config entries
 401                       #:old-entries old-entries)))
 402            (drvs -> (list bootcfg)))
 403         (mbegin %store-monad
 404           (show-what-to-build* drvs)
 405           (built-derivations drvs)
 406           ;; Only install bootloader configuration file.
 407           (install-bootloader local-eval bootloader-config bootcfg
 408                               #:run-installer? #f))))))
 409
 410 \f
 411 ;;;
 412 ;;; Graphs.
 413 ;;;
 414
 415 (define (service-node-label service)
 416   "Return a label to represent SERVICE."
 417   (let ((type  (service-kind service))
 418         (value (service-value service)))
 419     (string-append (symbol->string (service-type-name type))
 420                    (cond ((or (number? value) (symbol? value))
 421                           (string-append " " (object->string value)))
 422                          ((string? value)
 423                           (string-append " " value))
 424                          ((file-system? value)
 425                           (string-append " " (file-system-mount-point value)))
 426                          (else
 427                           "")))))
 428
 429 (define (service-node-type services)
 430   "Return a node type for SERVICES.  Since <service> instances are not
 431 self-contained (they express dependencies on service types, not on services),
 432 we have to create the 'edges' procedure dynamically as a function of the full
 433 list of services."
 434   (node-type
 435    (name "service")
 436    (description "the DAG of services")
 437    (identifier (lift1 object-address %store-monad))
 438    (label service-node-label)
 439    (edges (lift1 (service-back-edges services) %store-monad))))
 440
 441 (define (shepherd-service-node-label service)
 442   "Return a label for a node representing a <shepherd-service>."
 443   (string-join (map symbol->string (shepherd-service-provision service))))
 444
 445 (define (shepherd-service-node-type services)
 446   "Return a node type for SERVICES, a list of <shepherd-service>."
 447   (node-type
 448    (name "shepherd-service")
 449    (description "the dependency graph of shepherd services")
 450    (identifier (lift1 shepherd-service-node-label %store-monad))
 451    (label shepherd-service-node-label)
 452    (edges (lift1 (shepherd-service-back-edges services) %store-monad))))
 453
 454 \f
 455 ;;;
 456 ;;; Generations.
 457 ;;;
 458
 459 (define* (display-system-generation number
 460                                     #:optional (profile %system-profile))
 461   "Display a summary of system generation NUMBER in a human-readable format."
 462   (unless (zero? number)
 463     (let* ((generation  (generation-file-name profile number))
 464            (params      (read-boot-parameters-file generation))
 465            (label       (boot-parameters-label params))
 466            (bootloader-name (boot-parameters-bootloader-name params))
 467            (root        (boot-parameters-root-device params))
 468            (root-device (if (bytevector? root)
 469                             (uuid->string root)
 470                             root))
 471            (kernel      (boot-parameters-kernel params)))
 472       (display-generation profile number)
 473       (format #t (G_ "  file name: ~a~%") generation)
 474       (format #t (G_ "  canonical file name: ~a~%") (readlink* generation))
 475       ;; TRANSLATORS: Please preserve the two-space indentation.
 476       (format #t (G_ "  label: ~a~%") label)
 477       (format #t (G_ "  bootloader: ~a~%") bootloader-name)
 478
 479       ;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string must
 480       ;; be preserved.  They denote conditionals, such that the result will
 481       ;; look like:
 482       ;;   root device: UUID: 12345-678
 483       ;; or:
 484       ;;   root device: label: "my-root"
 485       ;; or just:
 486       ;;   root device: /dev/sda3
 487       (format #t (G_ "  root device: ~[UUID: ~a~;label: ~s~;~a~]~%")
 488               (cond ((uuid? root-device) 0)
 489                     ((file-system-label? root-device) 1)
 490                     (else 2))
 491               (cond ((uuid? root-device)
 492                      (uuid->string root-device))
 493                     ((file-system-label? root-device)
 494                      (file-system-label->string root-device))
 495                     (else
 496                      root-device)))
 497
 498       (format #t (G_ "  kernel: ~a~%") kernel))))
 499
 500 (define* (list-generations pattern #:optional (profile %system-profile))
 501   "Display in a human-readable format all the system generations matching
 502 PATTERN, a string.  When PATTERN is #f, display all the system generations."
 503   (cond ((not (file-exists? profile))             ; XXX: race condition
 504          (raise (condition (&profile-not-found-error
 505                             (profile profile)))))
 506         ((not pattern)
 507          (for-each display-system-generation (profile-generations profile)))
 508         ((matching-generations pattern profile)
 509          =>
 510          (lambda (numbers)
 511            (if (null-list? numbers)
 512                (exit 1)
 513                (leave-on-EPIPE
 514                 (for-each display-system-generation numbers)))))))
 515
 516 \f
 517 ;;;
 518 ;;; File system declaration checks.
 519 ;;;
 520
 521 (define (check-file-system-availability file-systems)
 522   "Check whether the UUIDs or partition labels that FILE-SYSTEMS refer to, if
 523 any, are available.  Raise an error if they're not."
 524   (define relevant
 525     (filter (lambda (fs)
 526               (and (file-system-mount? fs)
 527                    (not (member (file-system-type fs)
 528                                 %pseudo-file-system-types))
 529                    (not (memq 'bind-mount (file-system-flags fs)))))
 530             file-systems))
 531
 532   (define labeled
 533     (filter (lambda (fs)
 534               (file-system-label? (file-system-device fs)))
 535             relevant))
 536
 537   (define literal
 538     (filter (lambda (fs)
 539               (string? (file-system-device fs)))
 540             relevant))
 541
 542   (define uuid
 543     (filter (lambda (fs)
 544               (uuid? (file-system-device fs)))
 545             relevant))
 546
 547   (define fail? #f)
 548
 549   (define (file-system-location* fs)
 550     (location->string
 551      (source-properties->location
 552       (file-system-location fs))))
 553
 554   (let-syntax ((error (syntax-rules ()
 555                         ((_ args ...)
 556                          (begin
 557                            (set! fail? #t)
 558                            (format (current-error-port)
 559                                    args ...))))))
 560     (for-each (lambda (fs)
 561                 (catch 'system-error
 562                   (lambda ()
 563                     (stat (file-system-device fs)))
 564                   (lambda args
 565                     (let ((errno  (system-error-errno args))
 566                           (device (file-system-device fs)))
 567                       (error (G_ "~a: error: device '~a' not found: ~a~%")
 568                              (file-system-location* fs) device
 569                              (strerror errno))
 570                       (unless (string-prefix? "/" device)
 571                         (display-hint (format #f (G_ "If '~a' is a file system
 572 label, write @code{(file-system-label ~s)} in your @code{device} field.")
 573                                               device device)))))))
 574               literal)
 575     (for-each (lambda (fs)
 576                 (let ((label (file-system-label->string
 577                               (file-system-device fs))))
 578                   (unless (find-partition-by-label label)
 579                     (error (G_ "~a: error: file system with label '~a' not found~%")
 580                            (file-system-location* fs) label))))
 581               labeled)
 582     (for-each (lambda (fs)
 583                 (unless (find-partition-by-uuid (file-system-device fs))
 584                   (error (G_ "~a: error: file system with UUID '~a' not found~%")
 585                          (file-system-location* fs)
 586                          (uuid->string (file-system-device fs)))))
 587               uuid)
 588
 589     (when fail?
 590       ;; Better be safe than sorry.
 591       (exit 1))))
 592
 593 (define (check-mapped-devices os)
 594   "Check that each of MAPPED-DEVICES is valid according to the 'check'
 595 procedure of its type."
 596   (define boot-mapped-devices
 597     (operating-system-boot-mapped-devices os))
 598
 599   (define (needed-for-boot? md)
 600     (memq md boot-mapped-devices))
 601
 602   (define initrd-modules
 603     (operating-system-initrd-modules os))
 604
 605   (for-each (lambda (md)
 606               (let ((check (mapped-device-kind-check
 607                             (mapped-device-type md))))
 608                 ;; We expect CHECK to raise an exception with a detailed
 609                 ;; '&message' if something goes wrong.
 610                 (check md
 611                        #:needed-for-boot? (needed-for-boot? md)
 612                        #:initrd-modules initrd-modules)))
 613             (operating-system-mapped-devices os)))
 614
 615 (define (check-initrd-modules os)
 616   "Check that modules needed by 'needed-for-boot' file systems in OS are
 617 available in the initrd.  Note that mapped devices are responsible for
 618 checking this by themselves in their 'check' procedure."
 619   (define (file-system-/dev fs)
 620     (let ((device (file-system-device fs)))
 621       (match device
 622         ((? string?)
 623          device)
 624         ((? uuid?)
 625          (find-partition-by-uuid device))
 626         ((? file-system-label?)
 627          (find-partition-by-label (file-system-label->string device))))))
 628
 629   (define file-systems
 630     (filter file-system-needed-for-boot?
 631             (operating-system-file-systems os)))
 632
 633   (for-each (lambda (fs)
 634               (check-device-initrd-modules (file-system-/dev fs)
 635                                            (operating-system-initrd-modules os)
 636                                            (source-properties->location
 637                                             (file-system-location fs))))
 638             file-systems))
 639
 640 \f
 641 ;;;
 642 ;;; Action.
 643 ;;;
 644
 645 (define* (system-derivation-for-action os action
 646                                        #:key image-size file-system-type
 647                                        full-boot? container-shared-network?
 648                                        mappings)
 649   "Return as a monadic value the derivation for OS according to ACTION."
 650   (case action
 651     ((build init reconfigure)
 652      (operating-system-derivation os))
 653     ((container)
 654      (container-script
 655       os
 656       #:mappings mappings
 657       #:shared-network? container-shared-network?))
 658     ((vm-image)
 659      (system-qemu-image os #:disk-image-size image-size))
 660     ((vm)
 661      (system-qemu-image/shared-store-script os
 662                                             #:full-boot? full-boot?
 663                                             #:disk-image-size
 664                                             (if full-boot?
 665                                                 image-size
 666                                                 (* 70 (expt 2 20)))
 667                                             #:mappings mappings))
 668     ((disk-image)
 669      (system-disk-image os
 670                         #:name (match file-system-type
 671                                  ("iso9660" "image.iso")
 672                                  (_         "disk-image"))
 673                         #:disk-image-size image-size
 674                         #:file-system-type file-system-type))
 675     ((docker-image)
 676      (system-docker-image os))))
 677
 678 (define (maybe-suggest-running-guix-pull)
 679   "Suggest running 'guix pull' if this has never been done before."
 680   ;; The reason for this is that the 'guix' binding that we see here comes
 681   ;; from either ~/.config/latest or, if it's missing, from the
 682   ;; globally-installed Guix, which is necessarily older.  See
 683   ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for
 684   ;; a discussion.
 685   (define latest
 686     (string-append (config-directory) "/current"))
 687
 688   (unless (file-exists? latest)
 689     (warning (G_ "~a not found: 'guix pull' was never run~%") latest)
 690     (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%"))
 691     (warning (G_ "Failing to do that may downgrade your system!~%"))))
 692
 693 (define (bootloader-installer-script installer
 694                                      bootloader device target)
 695   "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE
 696 and TARGET arguments."
 697   (scheme-file "bootloader-installer"
 698                (with-imported-modules '((gnu build bootloader)
 699                                         (guix build utils))
 700                  #~(begin
 701                      (use-modules (gnu build bootloader)
 702                                   (guix build utils)
 703                                   (ice-9 binary-ports)
 704                                   (srfi srfi-34)
 705                                   (srfi srfi-35))
 706
 707                      (guard (c ((message-condition? c) ;XXX: i18n
 708                                 (format (current-error-port) "error: ~a~%"
 709                                         (condition-message c))
 710                                 (exit 1)))
 711                        (#$installer #$bootloader #$device #$target)
 712                        (info (G_ "bootloader successfully installed on '~a'~%")
 713                              #$device))))))
 714
 715 (define (local-eval exp)
 716   "Evaluate EXP, a G-Expression, in-place."
 717   (mlet* %store-monad ((lowered (lower-gexp exp))
 718                        (_ (built-derivations (lowered-gexp-inputs lowered))))
 719     (save-load-path-excursion
 720      (set! %load-path (lowered-gexp-load-path lowered))
 721      (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
 722      (return (primitive-eval (lowered-gexp-sexp lowered))))))
 723
 724 (define* (perform-action action os
 725                          #:key skip-safety-checks?
 726                          install-bootloader?
 727                          dry-run? derivations-only?
 728                          use-substitutes? bootloader-target target
 729                          image-size file-system-type full-boot?
 730                          container-shared-network?
 731                          (mappings '())
 732                          (gc-root #f))
 733   "Perform ACTION for OS.  INSTALL-BOOTLOADER? specifies whether to install
 734 bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
 735 target root directory; IMAGE-SIZE is the size of the image to be built, for
 736 the 'vm-image' and 'disk-image' actions.  The root file system is created as a
 737 FILE-SYSTEM-TYPE file system.  FULL-BOOT? is used for the 'vm' action; it
 738 determines whether to boot directly to the kernel or to the bootloader.
 739 CONTAINER-SHARED-NETWORK? determines if the container will use a separate
 740 network namespace.
 741
 742 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
 743 building anything.
 744
 745 When GC-ROOT is a path, also make that path an indirect root of the build
 746 output when building a system derivation, such as a disk image.
 747
 748 When SKIP-SAFETY-CHECKS? is true, skip the file system and initrd module
 749 static checks."
 750   (define println
 751     (cut format #t "~a~%" <>))
 752
 753   (define menu-entries
 754     (if (eq? 'init action)
 755         '()
 756         (map boot-parameters->menu-entry (profile-boot-parameters))))
 757
 758   (define bootloader
 759     (operating-system-bootloader os))
 760
 761   (define bootcfg
 762     (and (memq action '(init reconfigure))
 763          (operating-system-bootcfg os menu-entries)))
 764
 765   (when (eq? action 'reconfigure)
 766     (maybe-suggest-running-guix-pull))
 767
 768   ;; Check whether the declared file systems exist.  This is better than
 769   ;; instantiating a broken configuration.  Assume that we can only check if
 770   ;; running as root.
 771   (when (and (not skip-safety-checks?)
 772              (memq action '(init reconfigure)))
 773     (check-mapped-devices os)
 774     (when (zero? (getuid))
 775       (check-file-system-availability (operating-system-file-systems os))
 776       (check-initrd-modules os)))
 777
 778   (mlet* %store-monad
 779       ((sys       (system-derivation-for-action os action
 780                                                 #:file-system-type file-system-type
 781                                                 #:image-size image-size
 782                                                 #:full-boot? full-boot?
 783                                                 #:container-shared-network? container-shared-network?
 784                                                 #:mappings mappings))
 785
 786        ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
 787        ;; --no-bootloader is passed, because we then use it as a GC root.
 788        ;; See <http://bugs.gnu.org/21068>.
 789        (drvs      (mapm %store-monad lower-object
 790                         (if (memq action '(init reconfigure))
 791                             (list sys bootcfg)
 792                             (list sys))))
 793        (%         (if derivations-only?
 794                       (return (for-each (compose println derivation-file-name)
 795                                         drvs))
 796                       (maybe-build drvs #:dry-run? dry-run?
 797                                    #:use-substitutes? use-substitutes?))))
 798
 799     (if (or dry-run? derivations-only?)
 800         (return #f)
 801         (begin
 802           (for-each (compose println derivation->output-path)
 803                     drvs)
 804
 805           (case action
 806             ((reconfigure)
 807              (newline)
 808              (format #t (G_ "activating system...~%"))
 809              (mbegin %store-monad
 810                (switch-to-system local-eval os)
 811                (mwhen install-bootloader?
 812                  (install-bootloader local-eval bootloader bootcfg
 813                                      #:target (or target "/"))
 814                  (return
 815                   (info (G_ "bootloader successfully installed on '~a'~%")
 816                         (bootloader-configuration-target bootloader))))
 817                (with-shepherd-error-handling
 818                   (upgrade-shepherd-services local-eval os))))
 819             ((init)
 820              (newline)
 821              (format #t (G_ "initializing operating system under '~a'...~%")
 822                      target)
 823              (install sys (canonicalize-path target)
 824                       #:install-bootloader? install-bootloader?
 825                       #:bootloader bootloader
 826                       #:bootcfg bootcfg))
 827             (else
 828              ;; All we had to do was to build SYS and maybe register an
 829              ;; indirect GC root.
 830              (let ((output (derivation->output-path sys)))
 831                (mbegin %store-monad
 832                  (mwhen gc-root
 833                    (register-root* (list output) gc-root))
 834                  (return output)))))))))
 835
 836 (define (export-extension-graph os port)
 837   "Export the service extension graph of OS to PORT."
 838   (let* ((services (operating-system-services os))
 839          (system   (find (lambda (service)
 840                            (eq? (service-kind service) system-service-type))
 841                          services)))
 842     (export-graph (list system) (current-output-port)
 843                   #:node-type (service-node-type services)
 844                   #:reverse-edges? #t)))
 845
 846 (define (export-shepherd-graph os port)
 847   "Export the graph of shepherd services of OS to PORT."
 848   (let* ((services  (operating-system-services os))
 849          (pid1      (fold-services services
 850                                    #:target-type shepherd-root-service-type))
 851          (shepherds (service-value pid1))         ;list of <shepherd-service>
 852          (sinks     (filter (lambda (service)
 853                               (null? (shepherd-service-requirement service)))
 854                             shepherds)))
 855     (export-graph sinks (current-output-port)
 856                   #:node-type (shepherd-service-node-type shepherds)
 857                   #:reverse-edges? #t)))
 858
 859 \f
 860 ;;;
 861 ;;; Options.
 862 ;;;
 863
 864 (define (show-help)
 865   (display (G_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE]
 866 Build the operating system declared in FILE according to ACTION.
 867 Some ACTIONS support additional ARGS.\n"))
 868   (newline)
 869   (display (G_ "The valid values for ACTION are:\n"))
 870   (newline)
 871   (display (G_ "\
 872    search           search for existing service types\n"))
 873   (display (G_ "\
 874    reconfigure      switch to a new operating system configuration\n"))
 875   (display (G_ "\
 876    roll-back        switch to the previous operating system configuration\n"))
 877   (display (G_ "\
 878    list-generations list the system generations\n"))
 879   (display (G_ "\
 880    switch-generation switch to an existing operating system configuration\n"))
 881   (display (G_ "\
 882    delete-generations delete old system generations\n"))
 883   (display (G_ "\
 884    build            build the operating system without installing anything\n"))
 885   (display (G_ "\
 886    container        build a container that shares the host's store\n"))
 887   (display (G_ "\
 888    vm               build a virtual machine image that shares the host's store\n"))
 889   (display (G_ "\
 890    vm-image         build a freestanding virtual machine image\n"))
 891   (display (G_ "\
 892    disk-image       build a disk image, suitable for a USB stick\n"))
 893   (display (G_ "\
 894    docker-image     build a Docker image\n"))
 895   (display (G_ "\
 896    init             initialize a root file system to run GNU\n"))
 897   (display (G_ "\
 898    extension-graph  emit the service extension graph in Dot format\n"))
 899   (display (G_ "\
 900    shepherd-graph   emit the graph of shepherd services in Dot format\n"))
 901
 902   (show-build-options-help)
 903   (display (G_ "
 904   -d, --derivation       return the derivation of the given system"))
 905   (display (G_ "
 906   -e, --expression=EXPR  consider the operating-system EXPR evaluates to
 907                          instead of reading FILE, when applicable"))
 908   (display (G_ "
 909       --on-error=STRATEGY
 910                          apply STRATEGY (one of nothing-special, backtrace,
 911                          or debug) when an error occurs while reading FILE"))
 912   (display (G_ "
 913       --file-system-type=TYPE
 914                          for 'disk-image', produce a root file system of TYPE
 915                          (one of 'ext4', 'iso9660')"))
 916   (display (G_ "
 917       --image-size=SIZE  for 'vm-image', produce an image of SIZE"))
 918   (display (G_ "
 919       --no-bootloader    for 'init', do not install a bootloader"))
 920   (display (G_ "
 921       --share=SPEC       for 'vm', share host file system according to SPEC"))
 922   (display (G_ "
 923   -N, --network          for 'container', allow containers to access the network"))
 924   (display (G_ "
 925   -r, --root=FILE        for 'vm', 'vm-image', 'disk-image', 'container',
 926                          and 'build', make FILE a symlink to the result, and
 927                          register it as a garbage collector root"))
 928   (display (G_ "
 929       --expose=SPEC      for 'vm', expose host file system according to SPEC"))
 930   (display (G_ "
 931       --full-boot        for 'vm', make a full boot sequence"))
 932   (display (G_ "
 933       --skip-checks      skip file system and initrd module safety checks"))
 934   (display (G_ "
 935       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
 936   (display (G_ "
 937   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 938   (newline)
 939   (display (G_ "
 940   -h, --help             display this help and exit"))
 941   (display (G_ "
 942   -V, --version          display version information and exit"))
 943   (newline)
 944   (show-bug-report-information))
 945
 946 (define %options
 947   ;; Specifications of the command-line options.
 948   (cons* (option '(#\h "help") #f #f
 949                  (lambda args
 950                    (show-help)
 951                    (exit 0)))
 952          (option '(#\V "version") #f #f
 953                  (lambda args
 954                    (show-version-and-exit "guix system")))
 955          (option '(#\e "expression") #t #f
 956                  (lambda (opt name arg result)
 957                    (alist-cons 'expression arg result)))
 958          (option '(#\d "derivation") #f #f
 959                  (lambda (opt name arg result)
 960                    (alist-cons 'derivations-only? #t result)))
 961          (option '("on-error") #t #f
 962                  (lambda (opt name arg result)
 963                    (alist-cons 'on-error (string->symbol arg)
 964                                result)))
 965          (option '(#\t "file-system-type") #t #f
 966                  (lambda (opt name arg result)
 967                    (alist-cons 'file-system-type arg
 968                                result)))
 969          (option '("image-size") #t #f
 970                  (lambda (opt name arg result)
 971                    (alist-cons 'image-size (size->number arg)
 972                                result)))
 973          (option '(#\N "network") #f #f
 974                  (lambda (opt name arg result)
 975                    (alist-cons 'container-shared-network? #t result)))
 976          (option '("no-bootloader" "no-grub") #f #f
 977                  (lambda (opt name arg result)
 978                    (alist-cons 'install-bootloader? #f result)))
 979          (option '("full-boot") #f #f
 980                  (lambda (opt name arg result)
 981                    (alist-cons 'full-boot? #t result)))
 982          (option '("skip-checks") #f #f
 983                  (lambda (opt name arg result)
 984                    (alist-cons 'skip-safety-checks? #t result)))
 985
 986          (option '("share") #t #f
 987                  (lambda (opt name arg result)
 988                    (alist-cons 'file-system-mapping
 989                                (specification->file-system-mapping arg #t)
 990                                result)))
 991          (option '("expose") #t #f
 992                  (lambda (opt name arg result)
 993                    (alist-cons 'file-system-mapping
 994                                (specification->file-system-mapping arg #f)
 995                                result)))
 996
 997          (option '(#\n "dry-run") #f #f
 998                  (lambda (opt name arg result)
 999                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
1000          (option '(#\v "verbosity") #t #f
1001                  (lambda (opt name arg result)
1002                    (let ((level (string->number* arg)))
1003                      (alist-cons 'verbosity level
1004                                  (alist-delete 'verbosity result)))))
1005          (option '(#\s "system") #t #f
1006                  (lambda (opt name arg result)
1007                    (alist-cons 'system arg
1008                                (alist-delete 'system result eq?))))
1009          (option '("target") #t #f
1010                  (lambda (opt name arg result)
1011                    (alist-cons 'target arg
1012                                (alist-delete 'target result eq?))))
1013          (option '(#\r "root") #t #f
1014                  (lambda (opt name arg result)
1015                    (alist-cons 'gc-root arg result)))
1016          %standard-build-options))
1017
1018 (define %default-options
1019   ;; Alist of default option values.
1020   `((system . ,(%current-system))
1021     (target . #f)
1022     (substitutes? . #t)
1023     (offload? . #t)
1024     (print-build-trace? . #t)
1025     (print-extended-build-trace? . #t)
1026     (multiplexed-build-output? . #t)
1027     (graft? . #t)
1028     (debug . 0)
1029     (verbosity . #f)                              ;default
1030     (file-system-type . "ext4")
1031     (image-size . guess)
1032     (install-bootloader? . #t)))
1033
1034 \f
1035 ;;;
1036 ;;; Entry point.
1037 ;;;
1038
1039 (define (process-action action args opts)
1040   "Process ACTION, a sub-command, with the arguments are listed in ARGS.
1041 ACTION must be one of the sub-commands that takes an operating system
1042 declaration as an argument (a file name.)  OPTS is the raw alist of options
1043 resulting from command-line parsing."
1044   (define (ensure-operating-system file-or-exp obj)
1045     (unless (operating-system? obj)
1046       (leave (G_ "'~a' does not return an operating system~%")
1047              file-or-exp))
1048     obj)
1049
1050   (let* ((file        (match args
1051                         (() #f)
1052                         ((x . _) x)))
1053          (expr        (assoc-ref opts 'expression))
1054          (system      (assoc-ref opts 'system))
1055          (target      (assoc-ref opts 'target))
1056          (os          (ensure-operating-system
1057                        (or file expr)
1058                        (cond
1059                         ((and expr file)
1060                          (leave
1061                           (G_ "both file and expression cannot be specified~%")))
1062                         (expr
1063                          (read/eval expr))
1064                         (file
1065                          (load* file %user-module
1066                                 #:on-error (assoc-ref opts 'on-error)))
1067                         (else
1068                          (leave (G_ "no configuration specified~%"))))))
1069
1070          (dry?        (assoc-ref opts 'dry-run?))
1071          (bootloader? (assoc-ref opts 'install-bootloader?))
1072          (target-file (match args
1073                         ((first second) second)
1074                         (_ #f)))
1075          (bootloader-target
1076                       (and bootloader?
1077                            (bootloader-configuration-target
1078                             (operating-system-bootloader os)))))
1079
1080     (with-store store
1081       (set-build-options-from-command-line store opts)
1082
1083       (run-with-store store
1084         (mbegin %store-monad
1085           (set-guile-for-build (default-guile))
1086           (case action
1087             ((extension-graph)
1088              (export-extension-graph os (current-output-port)))
1089             ((shepherd-graph)
1090              (export-shepherd-graph os (current-output-port)))
1091             (else
1092              (unless (memq action '(build init))
1093                (warn-about-old-distro #:suggested-command
1094                                       "guix system reconfigure"))
1095
1096              (perform-action action os
1097                              #:dry-run? dry?
1098                              #:derivations-only? (assoc-ref opts
1099                                                             'derivations-only?)
1100                              #:use-substitutes? (assoc-ref opts 'substitutes?)
1101                              #:skip-safety-checks?
1102                              (assoc-ref opts 'skip-safety-checks?)
1103                              #:file-system-type (assoc-ref opts 'file-system-type)
1104                              #:image-size (assoc-ref opts 'image-size)
1105                              #:full-boot? (assoc-ref opts 'full-boot?)
1106                              #:container-shared-network?
1107                              (assoc-ref opts 'container-shared-network?)
1108                              #:mappings (filter-map (match-lambda
1109                                                       (('file-system-mapping . m)
1110                                                        m)
1111                                                       (_ #f))
1112                                                     opts)
1113                              #:install-bootloader? bootloader?
1114                              #:target target-file
1115                              #:bootloader-target bootloader-target
1116                              #:gc-root (assoc-ref opts 'gc-root)))))
1117         #:target target
1118         #:system system))
1119     (warn-about-disk-space)))
1120
1121 (define (resolve-subcommand name)
1122   (let ((module (resolve-interface
1123                  `(guix scripts system ,(string->symbol name))))
1124         (proc (string->symbol (string-append "guix-system-" name))))
1125     (module-ref module proc)))
1126
1127 (define (process-command command args opts)
1128   "Process COMMAND, one of the 'guix system' sub-commands.  ARGS is its
1129 argument list and OPTS is the option alist."
1130   (case command
1131     ;; The following commands do not need to use the store, and they do not need
1132     ;; an operating system configuration file.
1133     ((list-generations)
1134      (let ((pattern (match args
1135                       (() #f)
1136                       ((pattern) pattern)
1137                       (x (leave (G_ "wrong number of arguments~%"))))))
1138        (list-generations pattern)))
1139     ((search)
1140      (apply (resolve-subcommand "search") args))
1141     ;; The following commands need to use the store, but they do not need an
1142     ;; operating system configuration file.
1143     ((delete-generations)
1144      (let ((pattern (match args
1145                       (() #f)
1146                       ((pattern) pattern)
1147                       (x (leave (G_ "wrong number of arguments~%"))))))
1148        (with-store store
1149          (delete-matching-generations store %system-profile pattern)
1150          (reinstall-bootloader store (generation-number %system-profile)))))
1151     ((switch-generation)
1152      (let ((pattern (match args
1153                       ((pattern) pattern)
1154                       (x (leave (G_ "wrong number of arguments~%"))))))
1155        (with-store store
1156          (set-build-options-from-command-line store opts)
1157          (switch-to-system-generation store pattern))))
1158     ((roll-back)
1159      (let ((pattern (match args
1160                       (() "")
1161                       (x (leave (G_ "wrong number of arguments~%"))))))
1162        (with-store store
1163          (set-build-options-from-command-line store opts)
1164          (roll-back-system store))))
1165     ;; The following commands need to use the store, and they also
1166     ;; need an operating system configuration file.
1167     (else (process-action command args opts))))
1168
1169 (define (guix-system . args)
1170   (define (parse-sub-command arg result)
1171     ;; Parse sub-command ARG and augment RESULT accordingly.
1172     (if (assoc-ref result 'action)
1173         (alist-cons 'argument arg result)
1174         (let ((action (string->symbol arg)))
1175           (case action
1176             ((build container vm vm-image disk-image reconfigure init
1177               extension-graph shepherd-graph
1178               list-generations delete-generations roll-back
1179               switch-generation search docker-image)
1180              (alist-cons 'action action result))
1181             (else (leave (G_ "~a: unknown action~%") action))))))
1182
1183   (define (match-pair car)
1184     ;; Return a procedure that matches a pair with CAR.
1185     (match-lambda
1186       ((head . tail)
1187        (and (eq? car head) tail))
1188       (_ #f)))
1189
1190   (define (option-arguments opts)
1191     ;; Extract the plain arguments from OPTS.
1192     (let* ((args   (reverse (filter-map (match-pair 'argument) opts)))
1193            (count  (length args))
1194            (action (assoc-ref opts 'action))
1195            (expr   (assoc-ref opts 'expression)))
1196       (define (fail)
1197         (leave (G_ "wrong number of arguments for action '~a'~%")
1198                action))
1199
1200       (unless action
1201         (format (current-error-port)
1202                 (G_ "guix system: missing command name~%"))
1203         (format (current-error-port)
1204                 (G_ "Try 'guix system --help' for more information.~%"))
1205         (exit 1))
1206
1207       (case action
1208         ((build container vm vm-image disk-image docker-image reconfigure)
1209          (unless (or (= count 1)
1210                      (and expr (= count 0)))
1211            (fail)))
1212         ((init)
1213          (unless (= count 2)
1214            (fail))))
1215       args))
1216
1217   (with-error-handling
1218     (let* ((opts     (parse-command-line args %options
1219                                          (list %default-options)
1220                                          #:argument-handler
1221                                          parse-sub-command))
1222            (args     (option-arguments opts))
1223            (command  (assoc-ref opts 'action)))
1224       (parameterize ((%graft? (assoc-ref opts 'graft?)))
1225         (with-status-verbosity (or (assoc-ref opts 'verbosity)
1226                                    (if (eq? command 'build) 2 1))
1227           (process-command command args opts))))))
1228
1229 ;;; Local Variables:
1230 ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
1231 ;;; End:
1232
1233 ;;; system.scm ends here