guix/scripts/system.scm

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