guix/scripts/system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
   4 ;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com>
   5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix scripts system)
  23   #:use-module (guix config)
  24   #:use-module (guix ui)
  25   #:use-module (guix store)
  26   #:use-module (guix grafts)
  27   #:use-module (guix gexp)
  28   #:use-module (guix derivations)
  29   #:use-module (guix packages)
  30   #:use-module (guix utils)
  31   #:use-module (guix monads)
  32   #:use-module (guix records)
  33   #:use-module (guix profiles)
  34   #:use-module (guix scripts)
  35   #:use-module (guix scripts build)
  36   #:use-module (guix graph)
  37   #:use-module (guix scripts graph)
  38   #:use-module (guix build utils)
  39   #:use-module (gnu build install)
  40   #:use-module (gnu system)
  41   #:use-module (gnu system file-systems)
  42   #:use-module (gnu system linux-container)
  43   #:use-module (gnu system vm)
  44   #:use-module (gnu system grub)
  45   #:use-module (gnu services)
  46   #:use-module (gnu services shepherd)
  47   #:use-module (gnu services herd)
  48   #:use-module (srfi srfi-1)
  49   #:use-module (srfi srfi-11)
  50   #:use-module (srfi srfi-19)
  51   #:use-module (srfi srfi-26)
  52   #:use-module (srfi srfi-34)
  53   #:use-module (srfi srfi-35)
  54   #:use-module (srfi srfi-37)
  55   #:use-module (ice-9 match)
  56   #:use-module (rnrs bytevectors)
  57   #:export (guix-system
  58             read-operating-system))
  59
  60 \f
  61 ;;;
  62 ;;; Operating system declaration.
  63 ;;;
  64
  65 (define %user-module
  66   ;; Module in which the machine description file is loaded.
  67   (make-user-module '((gnu system)
  68                       (gnu services)
  69                       (gnu system shadow))))
  70
  71 (define (read-operating-system file)
  72   "Read the operating-system declaration from FILE and return it."
  73   (load* file %user-module))
  74
  75
  76 \f
  77 ;;;
  78 ;;; Installation.
  79 ;;;
  80
  81 (define-syntax-rule (save-load-path-excursion body ...)
  82   "Save the current values of '%load-path' and '%load-compiled-path', run
  83 BODY..., and restore them."
  84   (let ((path %load-path)
  85         (cpath %load-compiled-path))
  86     (dynamic-wind
  87       (const #t)
  88       (lambda ()
  89         body ...)
  90       (lambda ()
  91         (set! %load-path path)
  92         (set! %load-compiled-path cpath)))))
  93
  94 (define-syntax-rule (save-environment-excursion body ...)
  95   "Save the current environment variables, run BODY..., and restore them."
  96   (let ((env (environ)))
  97     (dynamic-wind
  98       (const #t)
  99       (lambda ()
 100         body ...)
 101       (lambda ()
 102         (environ env)))))
 103
 104 (define topologically-sorted*
 105   (store-lift topologically-sorted))
 106
 107
 108 (define* (copy-item item target
 109                     #:key (log-port (current-error-port)))
 110   "Copy ITEM to the store under root directory TARGET and register it."
 111   (mlet* %store-monad ((refs (references* item)))
 112     (let ((dest  (string-append target item))
 113           (state (string-append target "/var/guix")))
 114       (format log-port "copying '~a'...~%" item)
 115
 116       ;; Remove DEST if it exists to make sure that (1) we do not fail badly
 117       ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
 118       ;; (2) we end up with the right contents.
 119       (when (file-exists? dest)
 120         (delete-file-recursively dest))
 121
 122       (copy-recursively item dest
 123                         #:log (%make-void-port "w"))
 124
 125       ;; Register ITEM; as a side-effect, it resets timestamps, etc.
 126       ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
 127       ;; reproducing the user's current settings; see
 128       ;; <http://bugs.gnu.org/18049>.
 129       (unless (register-path item
 130                              #:prefix target
 131                              #:state-directory state
 132                              #:references refs)
 133         (leave (_ "failed to register '~a' under '~a'~%")
 134                item target))
 135
 136       (return #t))))
 137
 138 (define* (copy-closure item target
 139                        #:key (log-port (current-error-port)))
 140   "Copy ITEM and all its dependencies to the store under root directory
 141 TARGET, and register them."
 142   (mlet* %store-monad ((refs    (references* item))
 143                        (to-copy (topologically-sorted*
 144                                  (delete-duplicates (cons item refs)
 145                                                     string=?))))
 146     (sequence %store-monad
 147               (map (cut copy-item <> target #:log-port log-port)
 148                    to-copy))))
 149
 150 (define (install-grub* grub.cfg device target)
 151   "This is a variant of 'install-grub' with error handling, lifted in
 152 %STORE-MONAD"
 153   (let* ((gc-root      (string-append target %gc-roots-directory
 154                                       "/grub.cfg"))
 155          (temp-gc-root (string-append gc-root ".new"))
 156          (delete-file  (lift1 delete-file %store-monad))
 157          (make-symlink (lift2 switch-symlinks %store-monad))
 158          (rename       (lift2 rename-file %store-monad)))
 159     (mbegin %store-monad
 160       ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when
 161       ;; 'install-grub' completes (being a bit paranoid.)
 162       (make-symlink temp-gc-root grub.cfg)
 163
 164       (munless (false-if-exception (install-grub grub.cfg device target))
 165         (delete-file temp-gc-root)
 166         (leave (_ "failed to install GRUB on device '~a'~%") device))
 167
 168       ;; Register GRUB.CFG as a GC root so that its dependencies (background
 169       ;; image, font, etc.) are not reclaimed.
 170       (rename temp-gc-root gc-root))))
 171
 172 (define* (install os-drv target
 173                   #:key (log-port (current-output-port))
 174                   grub? grub.cfg device)
 175   "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to
 176 directory TARGET.  TARGET must be an absolute directory name since that's what
 177 'guix-register' expects.
 178
 179 When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
 180   (define (maybe-copy to-copy)
 181     (with-monad %store-monad
 182       (if (string=? target "/")
 183           (begin
 184             (warning (_ "initializing the current root file system~%"))
 185             (return #t))
 186           (begin
 187             ;; Make sure the target store exists.
 188             (mkdir-p (string-append target (%store-prefix)))
 189
 190             ;; Copy items to the new store.
 191             (copy-closure to-copy target #:log-port log-port)))))
 192
 193   ;; Make sure TARGET is root-owned when running as root, but still allow
 194   ;; non-root uses (useful for testing.)  See
 195   ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>.
 196   (if (zero? (geteuid))
 197       (chown target 0 0)
 198       (warning (_ "not running as 'root', so \
 199 the ownership of '~a' may be incorrect!~%")
 200                target))
 201
 202   (chmod target #o755)
 203   (let ((os-dir   (derivation->output-path os-drv))
 204         (format   (lift format %store-monad))
 205         (populate (lift2 populate-root-file-system %store-monad)))
 206
 207     (mbegin %store-monad
 208       ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's
 209       ;; background image and so on.
 210       (maybe-copy grub.cfg)
 211
 212       ;; Create a bunch of additional files.
 213       (format log-port "populating '~a'...~%" target)
 214       (populate os-dir target)
 215
 216       (mwhen grub?
 217         (install-grub* grub.cfg device target)))))
 218
 219 \f
 220 ;;;
 221 ;;; Reconfiguration.
 222 ;;;
 223
 224 (define %system-profile
 225   ;; The system profile.
 226   (string-append %state-directory "/profiles/system"))
 227
 228 (define-syntax-rule (with-shepherd-error-handling mbody ...)
 229   "Catch and report Shepherd errors that arise when binding MBODY, a monadic
 230 expression in %STORE-MONAD."
 231   (lambda (store)
 232     (catch 'system-error
 233       (lambda ()
 234         (guard (c ((shepherd-error? c)
 235                    (values (report-shepherd-error c) store)))
 236           (values (run-with-store store (begin mbody ...))
 237                   store)))
 238       (lambda (key proc format-string format-args errno . rest)
 239         (warning (_ "while talking to shepherd: ~a~%")
 240                  (apply format #f format-string format-args))
 241         (values #f store)))))
 242
 243 (define (report-shepherd-error error)
 244   "Report ERROR, a '&shepherd-error' error condition object."
 245   (cond ((service-not-found-error? error)
 246          (report-error (_ "service '~a' could not be found~%")
 247                        (service-not-found-error-service error)))
 248         ((action-not-found-error? error)
 249          (report-error (_ "service '~a' does not have an action '~a'~%")
 250                        (action-not-found-error-service error)
 251                        (action-not-found-error-action error)))
 252         ((action-exception-error? error)
 253          (report-error (_ "exception caught while executing '~a' \
 254 on service '~a':~%")
 255                        (action-exception-error-action error)
 256                        (action-exception-error-service error))
 257          (print-exception (current-error-port) #f
 258                           (action-exception-error-key error)
 259                           (action-exception-error-arguments error)))
 260         ((unknown-shepherd-error? error)
 261          (report-error (_ "something went wrong: ~s~%")
 262                        (unknown-shepherd-error-sexp error)))
 263         ((shepherd-error? error)
 264          (report-error (_ "shepherd error~%")))
 265         ((not error)                              ;not an error
 266          #t)))
 267
 268 (define (call-with-service-upgrade-info new-services mproc)
 269   "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of
 270 names of services to load (upgrade), and the list of names of services to
 271 unload."
 272   (match (current-services)
 273     ((services ...)
 274      (let-values (((to-unload to-load)
 275                    (shepherd-service-upgrade services new-services)))
 276        (mproc to-load
 277               (map (compose first live-service-provision)
 278                    to-unload))))
 279     (#f
 280      (with-monad %store-monad
 281        (warning (_ "failed to obtain list of shepherd services~%"))
 282        (return #f)))))
 283
 284 (define (upgrade-shepherd-services os)
 285   "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
 286 services specified in OS and not currently running.
 287
 288 This is currently very conservative in that it does not stop or unload any
 289 running service.  Unloading or stopping the wrong service ('udev', say) could
 290 bring the system down."
 291   (define new-services
 292     (service-parameters
 293      (fold-services (operating-system-services os)
 294                     #:target-type shepherd-root-service-type)))
 295
 296   ;; Arrange to simply emit a warning if the service upgrade fails.
 297   (with-shepherd-error-handling
 298    (call-with-service-upgrade-info new-services
 299      (lambda (to-load to-unload)
 300         (for-each (lambda (unload)
 301                     (info (_ "unloading service '~a'...~%") unload)
 302                     (unload-service unload))
 303                   to-unload)
 304
 305         (with-monad %store-monad
 306           (munless (null? to-load)
 307             (let ((to-load-names  (map shepherd-service-canonical-name to-load))
 308                   (to-start       (filter shepherd-service-auto-start? to-load)))
 309               (info (_ "loading new services:~{ ~a~}...~%") to-load-names)
 310               (mlet %store-monad ((files (mapm %store-monad shepherd-service-file
 311                                                to-load)))
 312                 ;; Here we assume that FILES are exactly those that were computed
 313                 ;; as part of the derivation that built OS, which is normally the
 314                 ;; case.
 315                 (load-services (map derivation->output-path files))
 316
 317                 (for-each start-service
 318                           (map shepherd-service-canonical-name to-start))
 319                 (return #t)))))))))
 320
 321 (define* (switch-to-system os
 322                            #:optional (profile %system-profile))
 323   "Make a new generation of PROFILE pointing to the directory of OS, switch to
 324 it atomically, and then run OS's activation script."
 325   (mlet* %store-monad ((drv    (operating-system-derivation os))
 326                        (script (operating-system-activation-script os)))
 327     (let* ((system     (derivation->output-path drv))
 328            (number     (+ 1 (generation-number profile)))
 329            (generation (generation-file-name profile number)))
 330       (switch-symlinks generation system)
 331       (switch-symlinks profile generation)
 332
 333       (format #t (_ "activating system...~%"))
 334
 335       ;; The activation script may change $PATH, among others, so protect
 336       ;; against that.
 337       (save-environment-excursion
 338        ;; Tell 'activate-current-system' what the new system is.
 339        (setenv "GUIX_NEW_SYSTEM" system)
 340
 341        ;; The activation script may modify '%load-path' & co., so protect
 342        ;; against that.  This is necessary to ensure that
 343        ;; 'upgrade-shepherd-services' gets to see the right modules when it
 344        ;; computes derivations with 'gexp->derivation'.
 345        (save-load-path-excursion
 346         (primitive-load (derivation->output-path script))))
 347
 348       ;; Finally, try to update system services.
 349       (upgrade-shepherd-services os))))
 350
 351 (define-syntax-rule (unless-file-not-found exp)
 352   (catch 'system-error
 353     (lambda ()
 354       exp)
 355     (lambda args
 356       (if (= ENOENT (system-error-errno args))
 357           #f
 358           (apply throw args)))))
 359
 360 (define (seconds->string seconds)
 361   "Return a string representing the date for SECONDS."
 362   (let ((time (make-time time-utc 0 seconds)))
 363     (date->string (time-utc->date time)
 364                   "~Y-~m-~d ~H:~M")))
 365
 366 (define* (profile-grub-entries #:optional (profile %system-profile)
 367                                   (numbers (generation-numbers profile)))
 368   "Return a list of 'menu-entry' for the generations of PROFILE specified by
 369 NUMBERS, which is a list of generation numbers."
 370   (define (system->grub-entry system number time)
 371     (unless-file-not-found
 372      (let* ((file             (string-append system "/parameters"))
 373             (params           (call-with-input-file file
 374                                 read-boot-parameters))
 375             (label            (boot-parameters-label params))
 376             (root             (boot-parameters-root-device params))
 377             (root-device      (if (bytevector? root)
 378                                   (uuid->string root)
 379                                   root))
 380             (kernel           (boot-parameters-kernel params))
 381             (kernel-arguments (boot-parameters-kernel-arguments params))
 382             (initrd           (boot-parameters-initrd params)))
 383        (menu-entry
 384         (label (string-append label " (#"
 385                               (number->string number) ", "
 386                               (seconds->string time) ")"))
 387         (device (boot-parameters-store-device params))
 388         (device-mount-point (boot-parameters-store-mount-point params))
 389         (linux kernel)
 390         (linux-arguments
 391          (cons* (string-append "--root=" root-device)
 392                 (string-append "--system=" system)
 393                 (string-append "--load=" system "/boot")
 394                 kernel-arguments))
 395         (initrd initrd)))))
 396
 397   (let* ((systems (map (cut generation-file-name profile <>)
 398                        numbers))
 399          (times   (map (lambda (system)
 400                          (unless-file-not-found
 401                           (stat:mtime (lstat system))))
 402                        systems)))
 403     (filter-map system->grub-entry systems numbers times)))
 404
 405 \f
 406 ;;;
 407 ;;; Roll-back.
 408 ;;;
 409 (define (roll-back-system store)
 410   "Roll back the system profile to its previous generation.  STORE is an open
 411 connection to the store."
 412   (switch-to-system-generation store "-1"))
 413 \f
 414 ;;;
 415 ;;; Switch generations.
 416 ;;;
 417 (define (switch-to-system-generation store spec)
 418   "Switch the system profile to the generation specified by SPEC, and
 419 re-install grub with a grub configuration file that uses the specified system
 420 generation as its default entry.  STORE is an open connection to the store."
 421   (let ((number (relative-generation-spec->number %system-profile spec)))
 422     (if number
 423         (begin
 424           (reinstall-grub store number)
 425           (switch-to-generation* %system-profile number))
 426         (leave (_ "cannot switch to system generation '~a'~%") spec))))
 427
 428 (define (reinstall-grub store number)
 429   "Re-install grub for existing system profile generation NUMBER.  STORE is an
 430 open connection to the store."
 431   (let* ((generation (generation-file-name %system-profile number))
 432          (file (string-append generation "/parameters"))
 433          (params (unless-file-not-found
 434                   (call-with-input-file file read-boot-parameters)))
 435          (root-device (boot-parameters-root-device params))
 436          ;; We don't currently keep track of past menu entries' details.  The
 437          ;; default values will allow the system to boot, even if they differ
 438          ;; from the actual past values for this generation's entry.
 439          (grub-config (grub-configuration (device root-device)))
 440          ;; Make the specified system generation the default entry.
 441          (entries (profile-grub-entries %system-profile (list number)))
 442          (old-generations (delv number (generation-numbers %system-profile)))
 443          (old-entries (profile-grub-entries %system-profile old-generations))
 444          (grub.cfg (run-with-store store
 445                      (grub-configuration-file grub-config
 446                                               entries
 447                                               #:old-entries old-entries))))
 448     (show-what-to-build store (list grub.cfg))
 449     (build-derivations store (list grub.cfg))
 450     ;; This is basically the same as install-grub*, but for now we avoid
 451     ;; re-installing the GRUB boot loader itself onto a device, mainly because
 452     ;; we don't in general have access to the same version of the GRUB package
 453     ;; which was used when installing this other system generation.
 454     (let* ((grub.cfg-path (derivation->output-path grub.cfg))
 455            (gc-root (string-append %gc-roots-directory "/grub.cfg"))
 456            (temp-gc-root (string-append gc-root ".new")))
 457       (switch-symlinks temp-gc-root grub.cfg-path)
 458       (unless (false-if-exception (install-grub-config grub.cfg-path "/"))
 459         (delete-file temp-gc-root)
 460         (leave (_ "failed to re-install GRUB configuration file: '~a'~%")
 461                grub.cfg-path))
 462       (rename-file temp-gc-root gc-root))))
 463
 464 \f
 465 ;;;
 466 ;;; Graphs.
 467 ;;;
 468
 469 (define (service-node-label service)
 470   "Return a label to represent SERVICE."
 471   (let ((type  (service-kind service))
 472         (value (service-parameters service)))
 473     (string-append (symbol->string (service-type-name type))
 474                    (cond ((or (number? value) (symbol? value))
 475                           (string-append " " (object->string value)))
 476                          ((string? value)
 477                           (string-append " " value))
 478                          ((file-system? value)
 479                           (string-append " " (file-system-mount-point value)))
 480                          (else
 481                           "")))))
 482
 483 (define (service-node-type services)
 484   "Return a node type for SERVICES.  Since <service> instances are not
 485 self-contained (they express dependencies on service types, not on services),
 486 we have to create the 'edges' procedure dynamically as a function of the full
 487 list of services."
 488   (node-type
 489    (name "service")
 490    (description "the DAG of services")
 491    (identifier (lift1 object-address %store-monad))
 492    (label service-node-label)
 493    (edges (lift1 (service-back-edges services) %store-monad))))
 494
 495 (define (shepherd-service-node-label service)
 496   "Return a label for a node representing a <shepherd-service>."
 497   (string-join (map symbol->string (shepherd-service-provision service))))
 498
 499 (define (shepherd-service-node-type services)
 500   "Return a node type for SERVICES, a list of <shepherd-service>."
 501   (node-type
 502    (name "shepherd-service")
 503    (description "the dependency graph of shepherd services")
 504    (identifier (lift1 shepherd-service-node-label %store-monad))
 505    (label shepherd-service-node-label)
 506    (edges (lift1 (shepherd-service-back-edges services) %store-monad))))
 507
 508 \f
 509 ;;;
 510 ;;; Generations.
 511 ;;;
 512
 513 (define* (display-system-generation number
 514                                     #:optional (profile %system-profile))
 515   "Display a summary of system generation NUMBER in a human-readable format."
 516   (unless (zero? number)
 517     (let* ((generation  (generation-file-name profile number))
 518            (param-file  (string-append generation "/parameters"))
 519            (params      (call-with-input-file param-file read-boot-parameters))
 520            (label       (boot-parameters-label params))
 521            (root        (boot-parameters-root-device params))
 522            (root-device (if (bytevector? root)
 523                             (uuid->string root)
 524                             root))
 525            (kernel      (boot-parameters-kernel params)))
 526       (display-generation profile number)
 527       (format #t (_ "  file name: ~a~%") generation)
 528       (format #t (_ "  canonical file name: ~a~%") (readlink* generation))
 529       ;; TRANSLATORS: Please preserve the two-space indentation.
 530       (format #t (_ "  label: ~a~%") label)
 531       (format #t (_ "  root device: ~a~%") root-device)
 532       (format #t (_ "  kernel: ~a~%") kernel))))
 533
 534 (define* (list-generations pattern #:optional (profile %system-profile))
 535   "Display in a human-readable format all the system generations matching
 536 PATTERN, a string.  When PATTERN is #f, display all the system generations."
 537   (cond ((not (file-exists? profile))             ; XXX: race condition
 538          (raise (condition (&profile-not-found-error
 539                             (profile profile)))))
 540         ((string-null? pattern)
 541          (for-each display-system-generation (profile-generations profile)))
 542         ((matching-generations pattern profile)
 543          =>
 544          (lambda (numbers)
 545            (if (null-list? numbers)
 546                (exit 1)
 547                (leave-on-EPIPE
 548                 (for-each display-system-generation numbers)))))
 549         (else
 550          (leave (_ "invalid syntax: ~a~%") pattern))))
 551
 552 \f
 553 ;;;
 554 ;;; Action.
 555 ;;;
 556
 557 (define* (system-derivation-for-action os action
 558                                        #:key image-size full-boot? mappings)
 559   "Return as a monadic value the derivation for OS according to ACTION."
 560   (case action
 561     ((build init reconfigure)
 562      (operating-system-derivation os))
 563     ((container)
 564      (container-script os #:mappings mappings))
 565     ((vm-image)
 566      (system-qemu-image os #:disk-image-size image-size))
 567     ((vm)
 568      (system-qemu-image/shared-store-script os
 569                                             #:full-boot? full-boot?
 570                                             #:disk-image-size
 571                                             (if full-boot?
 572                                                 image-size
 573                                                 (* 30 (expt 2 20)))
 574                                             #:mappings mappings))
 575     ((disk-image)
 576      (system-disk-image os #:disk-image-size image-size))))
 577
 578 (define (maybe-suggest-running-guix-pull)
 579   "Suggest running 'guix pull' if this has never been done before."
 580   ;; The reason for this is that the 'guix' binding that we see here comes
 581   ;; from either ~/.config/latest or, if it's missing, from the
 582   ;; globally-installed Guix, which is necessarily older.  See
 583   ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for
 584   ;; a discussion.
 585   (define latest
 586     (string-append (config-directory) "/latest"))
 587
 588   (unless (file-exists? latest)
 589     (warning (_ "~a not found: 'guix pull' was never run~%") latest)
 590     (warning (_ "Consider running 'guix pull' before 'reconfigure'.~%"))
 591     (warning (_ "Failing to do that may downgrade your system!~%"))))
 592
 593 (define* (perform-action action os
 594                          #:key grub? dry-run? derivations-only?
 595                          use-substitutes? device target
 596                          image-size full-boot?
 597                          (mappings '())
 598                          (gc-root #f))
 599   "Perform ACTION for OS.  GRUB? specifies whether to install GRUB; DEVICE is
 600 the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
 601 is the size of the image to be built, for the 'vm-image' and 'disk-image'
 602 actions.  FULL-BOOT? is used for the 'vm' action; it determines whether to
 603 boot directly to the kernel or to the bootloader.
 604
 605 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
 606 building anything.
 607
 608 When GC-ROOT is a path, also make that path an indirect root of the build
 609 output when building a system derivation, such as a disk image."
 610   (define println
 611     (cut format #t "~a~%" <>))
 612
 613   (when (eq? action 'reconfigure)
 614     (maybe-suggest-running-guix-pull))
 615
 616   (mlet* %store-monad
 617       ((sys       (system-derivation-for-action os action
 618                                                 #:image-size image-size
 619                                                 #:full-boot? full-boot?
 620                                                 #:mappings mappings))
 621        (grub      (package->derivation (grub-configuration-grub
 622                                         (operating-system-bootloader os))))
 623        (grub.cfg  (if (eq? 'container action)
 624                       (return #f)
 625                       (operating-system-bootcfg os
 626                                                 (if (eq? 'init action)
 627                                                     '()
 628                                                     (profile-grub-entries)))))
 629
 630        ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if
 631        ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC
 632        ;; root.  See <http://bugs.gnu.org/21068>.
 633        (drvs   -> (if (memq action '(init reconfigure))
 634                       (if grub?
 635                           (list sys grub.cfg grub)
 636                           (list sys grub.cfg))
 637                       (list sys)))
 638        (%         (if derivations-only?
 639                       (return (for-each (compose println derivation-file-name)
 640                                         drvs))
 641                       (maybe-build drvs #:dry-run? dry-run?
 642                                    #:use-substitutes? use-substitutes?))))
 643
 644     (if (or dry-run? derivations-only?)
 645         (return #f)
 646         (begin
 647           (for-each (compose println derivation->output-path)
 648                     drvs)
 649
 650           ;; Make sure GRUB is accessible.
 651           (when grub?
 652             (let ((prefix (derivation->output-path grub)))
 653               (setenv "PATH"
 654                       (string-append  prefix "/bin:" prefix "/sbin:"
 655                                       (getenv "PATH")))))
 656
 657           (case action
 658             ((reconfigure)
 659              (mbegin %store-monad
 660                (switch-to-system os)
 661                (mwhen grub?
 662                  (install-grub* (derivation->output-path grub.cfg)
 663                                 device "/"))))
 664             ((init)
 665              (newline)
 666              (format #t (_ "initializing operating system under '~a'...~%")
 667                      target)
 668              (install sys (canonicalize-path target)
 669                       #:grub? grub?
 670                       #:grub.cfg (derivation->output-path grub.cfg)
 671                       #:device device))
 672             (else
 673              ;; All we had to do was to build SYS and maybe register an
 674              ;; indirect GC root.
 675              (let ((output (derivation->output-path sys)))
 676                (mbegin %store-monad
 677                  (mwhen gc-root
 678                    (register-root* (list output) gc-root))
 679                  (return output)))))))))
 680
 681 (define (export-extension-graph os port)
 682   "Export the service extension graph of OS to PORT."
 683   (let* ((services (operating-system-services os))
 684          (system   (find (lambda (service)
 685                            (eq? (service-kind service) system-service-type))
 686                          services)))
 687     (export-graph (list system) (current-output-port)
 688                   #:node-type (service-node-type services)
 689                   #:reverse-edges? #t)))
 690
 691 (define (export-shepherd-graph os port)
 692   "Export the graph of shepherd services of OS to PORT."
 693   (let* ((services  (operating-system-services os))
 694          (pid1      (fold-services services
 695                                    #:target-type shepherd-root-service-type))
 696          (shepherds (service-parameters pid1)) ;list of <shepherd-service>
 697          (sinks     (filter (lambda (service)
 698                               (null? (shepherd-service-requirement service)))
 699                             shepherds)))
 700     (export-graph sinks (current-output-port)
 701                   #:node-type (shepherd-service-node-type shepherds)
 702                   #:reverse-edges? #t)))
 703
 704 \f
 705 ;;;
 706 ;;; Options.
 707 ;;;
 708
 709 (define (show-help)
 710   (display (_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE]
 711 Build the operating system declared in FILE according to ACTION.
 712 Some ACTIONS support additional ARGS.\n"))
 713   (newline)
 714   (display (_ "The valid values for ACTION are:\n"))
 715   (newline)
 716   (display (_ "\
 717    reconfigure      switch to a new operating system configuration\n"))
 718   (display (_ "\
 719    roll-back        switch to the previous operating system configuration\n"))
 720   (display (_ "\
 721    switch-generation switch to an existing operating system configuration\n"))
 722   (display (_ "\
 723    list-generations list the system generations\n"))
 724   (display (_ "\
 725    build            build the operating system without installing anything\n"))
 726   (display (_ "\
 727    container        build a container that shares the host's store\n"))
 728   (display (_ "\
 729    vm               build a virtual machine image that shares the host's store\n"))
 730   (display (_ "\
 731    vm-image         build a freestanding virtual machine image\n"))
 732   (display (_ "\
 733    disk-image       build a disk image, suitable for a USB stick\n"))
 734   (display (_ "\
 735    init             initialize a root file system to run GNU\n"))
 736   (display (_ "\
 737    extension-graph  emit the service extension graph in Dot format\n"))
 738   (display (_ "\
 739    shepherd-graph   emit the graph of shepherd services in Dot format\n"))
 740
 741   (show-build-options-help)
 742   (display (_ "
 743   -d, --derivation       return the derivation of the given system"))
 744   (display (_ "
 745       --on-error=STRATEGY
 746                          apply STRATEGY when an error occurs while reading FILE"))
 747   (display (_ "
 748       --image-size=SIZE  for 'vm-image', produce an image of SIZE"))
 749   (display (_ "
 750       --no-grub          for 'init', do not install GRUB"))
 751   (display (_ "
 752       --share=SPEC       for 'vm', share host file system according to SPEC"))
 753   (display (_ "
 754   -r, --root=FILE        for 'vm', 'vm-image', 'disk-image', 'container',
 755                          and 'build', make FILE a symlink to the result, and
 756                          register it as a garbage collector root"))
 757   (display (_ "
 758       --expose=SPEC      for 'vm', expose host file system according to SPEC"))
 759   (display (_ "
 760       --full-boot        for 'vm', make a full boot sequence"))
 761   (newline)
 762   (display (_ "
 763   -h, --help             display this help and exit"))
 764   (display (_ "
 765   -V, --version          display version information and exit"))
 766   (newline)
 767   (show-bug-report-information))
 768
 769 (define %options
 770   ;; Specifications of the command-line options.
 771   (cons* (option '(#\h "help") #f #f
 772                  (lambda args
 773                    (show-help)
 774                    (exit 0)))
 775          (option '(#\V "version") #f #f
 776                  (lambda args
 777                    (show-version-and-exit "guix system")))
 778          (option '(#\d "derivation") #f #f
 779                  (lambda (opt name arg result)
 780                    (alist-cons 'derivations-only? #t result)))
 781          (option '("on-error") #t #f
 782                  (lambda (opt name arg result)
 783                    (alist-cons 'on-error (string->symbol arg)
 784                                result)))
 785          (option '("image-size") #t #f
 786                  (lambda (opt name arg result)
 787                    (alist-cons 'image-size (size->number arg)
 788                                result)))
 789          (option '("no-grub") #f #f
 790                  (lambda (opt name arg result)
 791                    (alist-cons 'install-grub? #f result)))
 792          (option '("full-boot") #f #f
 793                  (lambda (opt name arg result)
 794                    (alist-cons 'full-boot? #t result)))
 795
 796          (option '("share") #t #f
 797                  (lambda (opt name arg result)
 798                    (alist-cons 'file-system-mapping
 799                                (specification->file-system-mapping arg #t)
 800                                result)))
 801          (option '("expose") #t #f
 802                  (lambda (opt name arg result)
 803                    (alist-cons 'file-system-mapping
 804                                (specification->file-system-mapping arg #f)
 805                                result)))
 806
 807          (option '(#\n "dry-run") #f #f
 808                  (lambda (opt name arg result)
 809                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
 810          (option '(#\s "system") #t #f
 811                  (lambda (opt name arg result)
 812                    (alist-cons 'system arg
 813                                (alist-delete 'system result eq?))))
 814          (option '(#\r "root") #t #f
 815                  (lambda (opt name arg result)
 816                    (alist-cons 'gc-root arg result)))
 817          %standard-build-options))
 818
 819 (define %default-options
 820   ;; Alist of default option values.
 821   `((system . ,(%current-system))
 822     (substitutes? . #t)
 823     (graft? . #t)
 824     (build-hook? . #t)
 825     (max-silent-time . 3600)
 826     (verbosity . 0)
 827     (image-size . ,(* 900 (expt 2 20)))
 828     (install-grub? . #t)))
 829
 830 \f
 831 ;;;
 832 ;;; Entry point.
 833 ;;;
 834
 835 (define (process-action action args opts)
 836   "Process ACTION, a sub-command, with the arguments are listed in ARGS.
 837 ACTION must be one of the sub-commands that takes an operating system
 838 declaration as an argument (a file name.)  OPTS is the raw alist of options
 839 resulting from command-line parsing."
 840   (let* ((file     (match args
 841                      (() #f)
 842                      ((x . _) x)))
 843          (system   (assoc-ref opts 'system))
 844          (os       (if file
 845                        (load* file %user-module
 846                               #:on-error (assoc-ref opts 'on-error))
 847                        (leave (_ "no configuration file specified~%"))))
 848
 849          (dry?     (assoc-ref opts 'dry-run?))
 850          (grub?    (assoc-ref opts 'install-grub?))
 851          (target   (match args
 852                      ((first second) second)
 853                      (_ #f)))
 854          (device   (and grub?
 855                         (grub-configuration-device
 856                          (operating-system-bootloader os)))))
 857
 858     (with-store store
 859       (set-build-options-from-command-line store opts)
 860
 861       (run-with-store store
 862         (mbegin %store-monad
 863           (set-guile-for-build (default-guile))
 864           (case action
 865             ((extension-graph)
 866              (export-extension-graph os (current-output-port)))
 867             ((shepherd-graph)
 868              (export-shepherd-graph os (current-output-port)))
 869             (else
 870              (perform-action action os
 871                              #:dry-run? dry?
 872                              #:derivations-only? (assoc-ref opts
 873                                                             'derivations-only?)
 874                              #:use-substitutes? (assoc-ref opts 'substitutes?)
 875                              #:image-size (assoc-ref opts 'image-size)
 876                              #:full-boot? (assoc-ref opts 'full-boot?)
 877                              #:mappings (filter-map (match-lambda
 878                                                       (('file-system-mapping . m)
 879                                                        m)
 880                                                       (_ #f))
 881                                                     opts)
 882                              #:grub? grub?
 883                              #:target target #:device device
 884                              #:gc-root (assoc-ref opts 'gc-root)))))
 885         #:system system))))
 886
 887 (define (process-command command args opts)
 888   "Process COMMAND, one of the 'guix system' sub-commands.  ARGS is its
 889 argument list and OPTS is the option alist."
 890   (case command
 891     ;; The following commands do not need to use the store, and they do not need
 892     ;; an operating system configuration file.
 893     ((list-generations)
 894      (let ((pattern (match args
 895                       (() "")
 896                       ((pattern) pattern)
 897                       (x (leave (_ "wrong number of arguments~%"))))))
 898        (list-generations pattern)))
 899     ;; The following commands need to use the store, but they do not need an
 900     ;; operating system configuration file.
 901     ((switch-generation)
 902      (let ((pattern (match args
 903                       ((pattern) pattern)
 904                       (x (leave (_ "wrong number of arguments~%"))))))
 905        (with-store store
 906          (set-build-options-from-command-line store opts)
 907          (switch-to-system-generation store pattern))))
 908     ((roll-back)
 909      (let ((pattern (match args
 910                       (() "")
 911                       (x (leave (_ "wrong number of arguments~%"))))))
 912        (with-store store
 913          (set-build-options-from-command-line store opts)
 914          (roll-back-system store))))
 915     ;; The following commands need to use the store, and they also
 916     ;; need an operating system configuration file.
 917     (else (process-action command args opts))))
 918
 919 (define (guix-system . args)
 920   (define (parse-sub-command arg result)
 921     ;; Parse sub-command ARG and augment RESULT accordingly.
 922     (if (assoc-ref result 'action)
 923         (alist-cons 'argument arg result)
 924         (let ((action (string->symbol arg)))
 925           (case action
 926             ((build container vm vm-image disk-image reconfigure init
 927               extension-graph shepherd-graph list-generations roll-back
 928               switch-generation)
 929              (alist-cons 'action action result))
 930             (else (leave (_ "~a: unknown action~%") action))))))
 931
 932   (define (match-pair car)
 933     ;; Return a procedure that matches a pair with CAR.
 934     (match-lambda
 935       ((head . tail)
 936        (and (eq? car head) tail))
 937       (_ #f)))
 938
 939   (define (option-arguments opts)
 940     ;; Extract the plain arguments from OPTS.
 941     (let* ((args   (reverse (filter-map (match-pair 'argument) opts)))
 942            (count  (length args))
 943            (action (assoc-ref opts 'action)))
 944       (define (fail)
 945         (leave (_ "wrong number of arguments for action '~a'~%")
 946                action))
 947
 948       (unless action
 949         (format (current-error-port)
 950                 (_ "guix system: missing command name~%"))
 951         (format (current-error-port)
 952                 (_ "Try 'guix system --help' for more information.~%"))
 953         (exit 1))
 954
 955       (case action
 956         ((build container vm vm-image disk-image reconfigure)
 957          (unless (= count 1)
 958            (fail)))
 959         ((init)
 960          (unless (= count 2)
 961            (fail))))
 962       args))
 963
 964   (with-error-handling
 965     (let* ((opts     (parse-command-line args %options
 966                                          (list %default-options)
 967                                          #:argument-handler
 968                                          parse-sub-command))
 969            (args     (option-arguments opts))
 970            (command  (assoc-ref opts 'action)))
 971       (parameterize ((%graft? (assoc-ref opts 'graft?)))
 972         (process-command command args opts)))))
 973
 974 ;;; Local Variables:
 975 ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
 976 ;;; End:
 977
 978 ;;; system.scm ends here