gnu/system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
   5 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
   6 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (gnu system)
  24   #:use-module (guix store)
  25   #:use-module (guix monads)
  26   #:use-module (guix gexp)
  27   #:use-module (guix records)
  28   #:use-module (guix packages)
  29   #:use-module (guix derivations)
  30   #:use-module (guix profiles)
  31   #:use-module (guix ui)
  32   #:use-module (gnu packages base)
  33   #:use-module (gnu packages bash)
  34   #:use-module (gnu packages guile)
  35   #:use-module (gnu packages admin)
  36   #:use-module (gnu packages linux)
  37   #:use-module (gnu packages pciutils)
  38   #:use-module (gnu packages package-management)
  39   #:use-module (gnu packages less)
  40   #:use-module (gnu packages zile)
  41   #:use-module (gnu packages nano)
  42   #:use-module (gnu packages lsof)
  43   #:use-module (gnu packages gawk)
  44   #:use-module (gnu packages man)
  45   #:use-module (gnu packages texinfo)
  46   #:use-module (gnu packages compression)
  47   #:use-module (gnu packages firmware)
  48   #:use-module (gnu services)
  49   #:use-module (gnu services shepherd)
  50   #:use-module (gnu services base)
  51   #:use-module (gnu bootloader)
  52   #:use-module (gnu system shadow)
  53   #:use-module (gnu system nss)
  54   #:use-module (gnu system locale)
  55   #:use-module (gnu system pam)
  56   #:use-module (gnu system linux-initrd)
  57   #:use-module (gnu system file-systems)
  58   #:use-module (gnu system mapped-devices)
  59   #:use-module (ice-9 match)
  60   #:use-module (srfi srfi-1)
  61   #:use-module (srfi srfi-26)
  62   #:use-module (srfi srfi-34)
  63   #:use-module (srfi srfi-35)
  64   #:use-module (rnrs bytevectors)
  65   #:export (operating-system
  66             operating-system?
  67
  68             operating-system-bootloader
  69             operating-system-services
  70             operating-system-user-services
  71             operating-system-packages
  72             operating-system-host-name
  73             operating-system-hosts-file
  74             operating-system-kernel
  75             operating-system-kernel-file
  76             operating-system-kernel-arguments
  77             operating-system-initrd
  78             operating-system-users
  79             operating-system-groups
  80             operating-system-issue
  81             operating-system-timezone
  82             operating-system-locale
  83             operating-system-locale-definitions
  84             operating-system-locale-libcs
  85             operating-system-mapped-devices
  86             operating-system-file-systems
  87             operating-system-store-file-system
  88             operating-system-user-mapped-devices
  89             operating-system-boot-mapped-devices
  90             operating-system-activation-script
  91             operating-system-user-accounts
  92             operating-system-shepherd-service-names
  93
  94             operating-system-derivation
  95             operating-system-profile
  96             operating-system-bootcfg
  97             operating-system-etc-directory
  98             operating-system-locale-directory
  99             operating-system-boot-script
 100
 101             system-linux-image-file-name
 102
 103             boot-parameters
 104             boot-parameters?
 105             boot-parameters-label
 106             boot-parameters-root-device
 107             boot-parameters-boot-name
 108             boot-parameters-store-device
 109             boot-parameters-store-mount-point
 110             boot-parameters-kernel
 111             boot-parameters-kernel-arguments
 112             boot-parameters-initrd
 113             read-boot-parameters
 114             read-boot-parameters-file
 115
 116             local-host-aliases
 117             %setuid-programs
 118             %base-packages
 119             %base-firmware))
 120
 121 ;;; Commentary:
 122 ;;;
 123 ;;; This module supports whole-system configuration.
 124 ;;;
 125 ;;; Code:
 126
 127 (define (bootable-kernel-arguments kernel-arguments system.drv root-device)
 128   "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be
 129 booted from ROOT-DEVICE"
 130   (cons* (string-append "--root=" root-device)
 131          #~(string-append "--system=" #$system.drv)
 132          #~(string-append "--load=" #$system.drv "/boot")
 133          kernel-arguments))
 134
 135 ;; System-wide configuration.
 136 ;; TODO: Add per-field docstrings/stexi.
 137 (define-record-type* <operating-system> operating-system
 138   make-operating-system
 139   operating-system?
 140   (kernel operating-system-kernel                 ; package
 141           (default linux-libre))
 142   (kernel-arguments operating-system-user-kernel-arguments
 143                     (default '()))                ; list of gexps/strings
 144   (bootloader operating-system-bootloader)        ; <bootloader-configuration>
 145
 146   (initrd operating-system-initrd                 ; (list fs) -> M derivation
 147           (default base-initrd))
 148   (firmware operating-system-firmware             ; list of packages
 149             (default %base-firmware))
 150
 151   (host-name operating-system-host-name)          ; string
 152   (hosts-file operating-system-hosts-file         ; file-like | #f
 153               (default #f))
 154
 155   (mapped-devices operating-system-mapped-devices ; list of <mapped-device>
 156                   (default '()))
 157   (file-systems operating-system-file-systems)    ; list of fs
 158   (swap-devices operating-system-swap-devices     ; list of strings
 159                 (default '()))
 160
 161   (users operating-system-users                   ; list of user accounts
 162          (default %base-user-accounts))
 163   (groups operating-system-groups                 ; list of user groups
 164           (default %base-groups))
 165
 166   (skeletons operating-system-skeletons           ; list of name/monadic value
 167              (default (default-skeletons)))
 168   (issue operating-system-issue                   ; string
 169          (default %default-issue))
 170
 171   (packages operating-system-packages             ; list of (PACKAGE OUTPUT...)
 172             (default %base-packages))             ; or just PACKAGE
 173
 174   (timezone operating-system-timezone)            ; string
 175   (locale   operating-system-locale               ; string
 176             (default "en_US.utf8"))
 177   (locale-definitions operating-system-locale-definitions ; list of <locale-definition>
 178                       (default %default-locale-definitions))
 179   (locale-libcs operating-system-locale-libcs     ; list of <packages>
 180                 (default %default-locale-libcs))
 181   (name-service-switch operating-system-name-service-switch ; <name-service-switch>
 182                        (default %default-nss))
 183
 184   (services operating-system-user-services        ; list of monadic services
 185             (default %base-services))
 186
 187   (pam-services operating-system-pam-services     ; list of PAM services
 188                 (default (base-pam-services)))
 189   (setuid-programs operating-system-setuid-programs
 190                    (default %setuid-programs))    ; list of string-valued gexps
 191
 192   (sudoers-file operating-system-sudoers-file     ; file-like
 193                 (default %sudoers-specification)))
 194
 195 (define (operating-system-kernel-arguments os system.drv root-device)
 196   "Return all the kernel arguments, including the ones not specified
 197 directly by the user."
 198   (bootable-kernel-arguments (operating-system-user-kernel-arguments os)
 199                              system.drv
 200                              root-device))
 201
 202 \f
 203 ;;;
 204 ;;; Boot parameters
 205 ;;;
 206
 207 (define-record-type* <boot-parameters>
 208   boot-parameters make-boot-parameters boot-parameters?
 209   (label            boot-parameters-label)
 210   ;; Because we will use the 'store-device' to create the GRUB search command,
 211   ;; the 'store-device' has slightly different semantics than 'root-device'.
 212   ;; The 'store-device' can be a file system uuid, a file system label, or #f,
 213   ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not
 214   ;; understand that.  The 'root-device', on the other hand, corresponds
 215   ;; exactly to the device field of the <file-system> object representing the
 216   ;; OS's root file system, so it might be a device path like "/dev/sda3".
 217   (root-device      boot-parameters-root-device)
 218   (boot-name        boot-parameters-boot-name)
 219   (store-device     boot-parameters-store-device)
 220   (store-mount-point boot-parameters-store-mount-point)
 221   (kernel           boot-parameters-kernel)
 222   (kernel-arguments boot-parameters-kernel-arguments)
 223   (initrd           boot-parameters-initrd))
 224
 225 (define (read-boot-parameters port)
 226   "Read boot parameters from PORT and return the corresponding
 227 <boot-parameters> object or #f if the format is unrecognized."
 228   (match (read port)
 229     (('boot-parameters ('version 0)
 230                        ('label label) ('root-device root)
 231                        ('kernel linux)
 232                        rest ...)
 233      (boot-parameters
 234       (label label)
 235       (root-device root)
 236
 237       (boot-name
 238        (match (assq 'boot-name rest)
 239          ((_ args) args)
 240          (#f       'grub))) ; for compatibility reasons.
 241
 242       ;; In the past, we would store the directory name of the kernel instead
 243       ;; of the absolute file name of its image.  Detect that and correct it.
 244       (kernel (if (string=? linux (direct-store-path linux))
 245                   (string-append linux "/"
 246                                  (system-linux-image-file-name))
 247                   linux))
 248
 249       (kernel-arguments
 250        (match (assq 'kernel-arguments rest)
 251          ((_ args) args)
 252          (#f       '())))                         ;the old format
 253
 254       (initrd
 255        (match (assq 'initrd rest)
 256          (('initrd ('string-append directory file)) ;the old format
 257           (string-append directory file))
 258          (('initrd (? string? file))
 259           file)))
 260
 261       (store-device
 262        (match (assq 'store rest)
 263          (('store ('device device) _ ...)
 264           device)
 265          (_                                       ;the old format
 266           ;; Root might be a device path like "/dev/sda1", which is not a
 267           ;; suitable GRUB device identifier.
 268           (if (string-prefix? "/" root)
 269               #f
 270               root))))
 271
 272       (store-mount-point
 273        (match (assq 'store rest)
 274          (('store ('device _) ('mount-point mount-point) _ ...)
 275           mount-point)
 276          (_                                       ;the old format
 277           "/")))))
 278     (x                                            ;unsupported format
 279      (warning (G_ "unrecognized boot parameters for '~a'~%")
 280               system)
 281      #f)))
 282
 283 (define (read-boot-parameters-file system)
 284   "Read boot parameters from SYSTEM's (system or generation) \"parameters\"
 285 file and returns the corresponding <boot-parameters> object or #f if the
 286 format is unrecognized.
 287 The object has its kernel-arguments extended in order to make it bootable."
 288   (let* ((file (string-append system "/parameters"))
 289          (params (call-with-input-file file read-boot-parameters))
 290          (root (boot-parameters-root-device params))
 291          (root-device (if (bytevector? root)
 292                           (uuid->string root)
 293                           root))
 294          (kernel-arguments (boot-parameters-kernel-arguments params)))
 295     (if params
 296       (boot-parameters
 297         (inherit params)
 298         (kernel-arguments (bootable-kernel-arguments kernel-arguments
 299                                                      system
 300                                                      root-device)))
 301       #f)))
 302 \f
 303 ;;;
 304 ;;; Services.
 305 ;;;
 306
 307 (define (non-boot-file-system-service os)
 308   "Return the file system service for the file systems of OS that are not
 309 marked as 'needed-for-boot'."
 310   (define file-systems
 311     (remove file-system-needed-for-boot?
 312             (operating-system-file-systems os)))
 313
 314   (define (device-mappings fs)
 315     (let ((device (file-system-device fs)))
 316       (if (string? device)                        ;title is 'device
 317           (filter (lambda (md)
 318                     (string=? (string-append "/dev/mapper/"
 319                                              (mapped-device-target md))
 320                               device))
 321                   (operating-system-mapped-devices os))
 322           '())))
 323
 324   (define (add-dependencies fs)
 325     ;; Add the dependencies due to device mappings to FS.
 326     (file-system
 327       (inherit fs)
 328       (dependencies
 329        (delete-duplicates (append (device-mappings fs)
 330                                   (file-system-dependencies fs))
 331                           eq?))))
 332
 333   (service file-system-service-type
 334            (map add-dependencies file-systems)))
 335
 336 (define (mapped-device-user device file-systems)
 337   "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
 338   (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
 339     (find (lambda (fs)
 340             (or (member device (file-system-dependencies fs))
 341                 (and (eq? 'device (file-system-title fs))
 342                      (string=? (file-system-device fs) target))))
 343           file-systems)))
 344
 345 (define (operating-system-user-mapped-devices os)
 346   "Return the subset of mapped devices that can be installed in
 347 user-land--i.e., those not needed during boot."
 348   (let ((devices      (operating-system-mapped-devices os))
 349         (file-systems (operating-system-file-systems os)))
 350    (filter (lambda (md)
 351              (let ((user (mapped-device-user md file-systems)))
 352                (or (not user)
 353                    (not (file-system-needed-for-boot? user)))))
 354            devices)))
 355
 356 (define (operating-system-boot-mapped-devices os)
 357   "Return the subset of mapped devices that must be installed during boot,
 358 from the initrd."
 359   (let ((devices      (operating-system-mapped-devices os))
 360         (file-systems (operating-system-file-systems os)))
 361    (filter (lambda (md)
 362              (let ((user (mapped-device-user md file-systems)))
 363                (and user (file-system-needed-for-boot? user))))
 364            devices)))
 365
 366 (define (device-mapping-services os)
 367   "Return the list of device-mapping services for OS as a list."
 368   (map device-mapping-service
 369        (operating-system-user-mapped-devices os)))
 370
 371 (define (swap-services os)
 372   "Return the list of swap services for OS."
 373   (map swap-service (operating-system-swap-devices os)))
 374
 375 (define* (system-linux-image-file-name #:optional (system (%current-system)))
 376   "Return the basename of the kernel image file for SYSTEM."
 377   ;; FIXME: Evaluate the conditional based on the actual current system.
 378   (cond
 379    ((string-prefix? "arm" (%current-system)) "zImage")
 380    ((string-prefix? "mips" (%current-system)) "vmlinuz")
 381    (else "bzImage")))
 382
 383 (define (operating-system-kernel-file os)
 384   "Return an object representing the absolute file name of the kernel image of
 385 OS."
 386   (file-append (operating-system-kernel os)
 387                "/" (system-linux-image-file-name os)))
 388
 389 (define* (operating-system-directory-base-entries os #:key container?)
 390   "Return the basic entries of the 'system' directory of OS for use as the
 391 value of the SYSTEM-SERVICE-TYPE service."
 392   (mlet %store-monad ((locale (operating-system-locale-directory os)))
 393     (if container?
 394         (return `(("locale" ,locale)))
 395         (mlet %store-monad
 396             ((kernel  ->  (operating-system-kernel os))
 397              (initrd      (operating-system-initrd-file os))
 398              (params      (operating-system-boot-parameters-file os)))
 399           (return `(("kernel" ,kernel)
 400                     ("parameters" ,params)
 401                     ("initrd" ,initrd)
 402                     ("locale" ,locale)))))))      ;used by libc
 403
 404 (define* (essential-services os #:key container?)
 405   "Return the list of essential services for OS.  These are special services
 406 that implement part of what's declared in OS are responsible for low-level
 407 bookkeeping.  CONTAINER? determines whether to return the list of services for
 408 a container or that of a \"bare metal\" system."
 409   (define known-fs
 410     (map file-system-mount-point (operating-system-file-systems os)))
 411
 412   (let* ((mappings  (device-mapping-services os))
 413          (root-fs   (root-file-system-service))
 414          (other-fs  (non-boot-file-system-service os))
 415          (unmount   (user-unmount-service known-fs))
 416          (swaps     (swap-services os))
 417          (procs     (user-processes-service))
 418          (host-name (host-name-service (operating-system-host-name os)))
 419          (entries   (operating-system-directory-base-entries
 420                      os #:container? container?)))
 421     (cons* (service system-service-type entries)
 422            %boot-service
 423
 424            ;; %SHEPHERD-ROOT-SERVICE must come first so that the gexp that
 425            ;; execs shepherd comes last in the boot script (XXX).  Likewise,
 426            ;; the cleanup service must come last so that its gexp runs before
 427            ;; activation code.
 428            %shepherd-root-service
 429            %activation-service
 430            (service cleanup-service-type #f)
 431
 432            (pam-root-service (operating-system-pam-services os))
 433            (account-service (append (operating-system-accounts os)
 434                                     (operating-system-groups os))
 435                             (operating-system-skeletons os))
 436            (operating-system-etc-service os)
 437            (service fstab-service-type '())
 438            (session-environment-service
 439             (operating-system-environment-variables os))
 440            host-name procs root-fs unmount
 441            (service setuid-program-service-type
 442                     (operating-system-setuid-programs os))
 443            (service profile-service-type
 444                     (operating-system-packages os))
 445            other-fs
 446            (append mappings swaps
 447
 448                    ;; Add the firmware service, unless we are building for a
 449                    ;; container.
 450                    (if container?
 451                        '()
 452                        (list %linux-bare-metal-service
 453                              (service firmware-service-type
 454                                       (operating-system-firmware os))))))))
 455
 456 (define* (operating-system-services os #:key container?)
 457   "Return all the services of OS, including \"internal\" services that do not
 458 explicitly appear in OS."
 459   (append (operating-system-user-services os)
 460           (essential-services os #:container? container?)))
 461
 462 \f
 463 ;;;
 464 ;;; /etc.
 465 ;;;
 466
 467 (define %base-firmware
 468   ;; Firmware usable by default.
 469   (list ath9k-htc-firmware
 470         openfwwf-firmware))
 471
 472 (define %base-packages
 473   ;; Default set of packages globally visible.  It should include anything
 474   ;; required for basic administrator tasks.
 475   (cons* procps psmisc which less zile nano
 476          lsof                                 ;for Guix's 'list-runtime-roots'
 477          pciutils usbutils
 478          util-linux inetutils isc-dhcp
 479
 480          ;; wireless-tools is deprecated in favor of iw, but it's still what
 481          ;; many people are familiar with, so keep it around.
 482          iw wireless-tools rfkill
 483
 484          iproute
 485          net-tools                        ; XXX: remove when Inetutils suffices
 486          man-db
 487          info-reader                     ;the standalone Info reader (no Perl)
 488
 489          ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
 490          ;; want the other commands and the man pages (notably because
 491          ;; auto-completion in Emacs shell relies on man pages.)
 492          sudo
 493
 494          ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
 495          ;; already depends on it anyway.
 496          kmod eudev
 497
 498          e2fsprogs kbd
 499
 500          bash-completion
 501
 502          ;; The packages below are also in %FINAL-INPUTS, so take them from
 503          ;; there to avoid duplication.
 504          (map canonical-package
 505               (list guile-2.0 bash coreutils-8.27 findutils grep sed
 506                     diffutils patch gawk tar gzip bzip2 xz lzip))))
 507
 508 (define %default-issue
 509   ;; Default contents for /etc/issue.
 510   "
 511 This is the GNU system.  Welcome.\n")
 512
 513 (define (local-host-aliases host-name)
 514   "Return aliases for HOST-NAME, to be used in /etc/hosts."
 515   (string-append "127.0.0.1 localhost " host-name "\n"
 516                  "::1       localhost " host-name "\n"))
 517
 518 (define (default-/etc/hosts host-name)
 519   "Return the default /etc/hosts file."
 520   (plain-file "hosts" (local-host-aliases host-name)))
 521
 522 (define* (operating-system-etc-service os)
 523   "Return a <service> that builds containing the static part of the /etc
 524 directory."
 525   (let ((login.defs (plain-file "login.defs" "# Empty for now.\n"))
 526
 527         (issue      (plain-file "issue" (operating-system-issue os)))
 528         (nsswitch   (plain-file "nsswitch.conf"
 529                                 (name-service-switch->string
 530                                  (operating-system-name-service-switch os))))
 531
 532         ;; Startup file for POSIX-compliant login shells, which set system-wide
 533         ;; environment variables.
 534         (profile    (mixed-text-file "profile"  "\
 535 # Crucial variables that could be missing in the profiles' 'etc/profile'
 536 # because they would require combining both profiles.
 537 # FIXME: See <http://bugs.gnu.org/20255>.
 538 export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man
 539 export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info
 540 export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share
 541 export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg
 542
 543 # Ignore the default value of 'PATH'.
 544 unset PATH
 545
 546 # Load the system profile's settings.
 547 GUIX_PROFILE=/run/current-system/profile \\
 548 . /run/current-system/profile/etc/profile
 549
 550 # Prepend setuid programs.
 551 export PATH=/run/setuid-programs:$PATH
 552
 553 # Since 'lshd' does not use pam_env, /etc/environment must be explicitly
 554 # loaded when someone logs in via SSH.  See <http://bugs.gnu.org/22175>.
 555 # We need 'PATH' to be defined here, for 'cat' and 'cut'.  Do this before
 556 # reading the user's 'etc/profile' to allow variables to be overridden.
 557 if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\
 558      -a -z \"$LINUX_MODULE_DIRECTORY\" ]
 559 then
 560   . /etc/environment
 561   export `cat /etc/environment | cut -d= -f1`
 562 fi
 563
 564 if [ -f \"$HOME/.guix-profile/etc/profile\" ]
 565 then
 566   # Load the user profile's settings.
 567   GUIX_PROFILE=\"$HOME/.guix-profile\" \\
 568   . \"$HOME/.guix-profile/etc/profile\"
 569 else
 570   # At least define this one so that basic things just work
 571   # when the user installs their first package.
 572   export PATH=\"$HOME/.guix-profile/bin:$PATH\"
 573 fi
 574
 575 # Set the umask, notably for users logging in via 'lsh'.
 576 # See <http://bugs.gnu.org/22650>.
 577 umask 022
 578
 579 # Allow GStreamer-based applications to find plugins.
 580 export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"
 581
 582 if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ]
 583 then
 584   # Load Bash-specific initialization code.
 585   . /etc/bashrc
 586 fi
 587 "))
 588
 589         (bashrc    (plain-file "bashrc" "\
 590 # Bash-specific initialization.
 591
 592 # The 'bash-completion' package.
 593 if [ -f /run/current-system/profile/etc/profile.d/bash_completion.sh ]
 594 then
 595   # Bash-completion sources ~/.bash_completion.  It installs a dynamic
 596   # completion loader that searches its own completion files as well
 597   # as those in ~/.guix-profile and /run/current-system/profile.
 598   source /run/current-system/profile/etc/profile.d/bash_completion.sh
 599 fi\n")))
 600     (etc-service
 601      `(("services" ,(file-append net-base "/etc/services"))
 602        ("protocols" ,(file-append net-base "/etc/protocols"))
 603        ("rpc" ,(file-append net-base "/etc/rpc"))
 604        ("login.defs" ,#~#$login.defs)
 605        ("issue" ,#~#$issue)
 606        ("nsswitch.conf" ,#~#$nsswitch)
 607        ("profile" ,#~#$profile)
 608        ("bashrc" ,#~#$bashrc)
 609        ("hosts" ,#~#$(or (operating-system-hosts-file os)
 610                          (default-/etc/hosts (operating-system-host-name os))))
 611        ("localtime" ,(file-append tzdata "/share/zoneinfo/"
 612                                   (operating-system-timezone os)))
 613        ("sudoers" ,(operating-system-sudoers-file os))))))
 614
 615 (define %root-account
 616   ;; Default root account.
 617   (user-account
 618    (name "root")
 619    (password "")
 620    (uid 0) (group "root")
 621    (comment "System administrator")
 622    (home-directory "/root")))
 623
 624 (define (operating-system-accounts os)
 625   "Return the user accounts for OS, including an obligatory 'root' account,
 626 and excluding accounts requested by services."
 627   ;; Make sure there's a root account.
 628   (if (find (lambda (user)
 629               (and=> (user-account-uid user) zero?))
 630             (operating-system-users os))
 631       (operating-system-users os)
 632       (cons %root-account (operating-system-users os))))
 633
 634 (define (maybe-string->file file-name thing)
 635   "If THING is a string, return a <plain-file> with THING as its content.
 636 Otherwise just return THING.
 637
 638 This is for backward-compatibility of fields that used to be strings and are
 639 now file-like objects.."
 640   (match thing
 641     ((? string?)
 642      (warning (G_ "using a string for file '~a' is deprecated; \
 643 use 'plain-file' instead~%")
 644               file-name)
 645      (plain-file file-name thing))
 646     (x
 647      x)))
 648
 649 (define (maybe-file->monadic file-name thing)
 650   "If THING is a value in %STORE-MONAD, return it as is; otherwise return
 651 THING in the %STORE-MONAD.
 652
 653 This is for backward-compatibility of fields that used to be monadic values
 654 and are now file-like objects."
 655   (with-monad %store-monad
 656     (match thing
 657       ((? procedure?)
 658        (warning (G_ "using a monadic value for '~a' is deprecated; \
 659 use 'plain-file' instead~%")
 660                 file-name)
 661        thing)
 662       (x
 663        (return x)))))
 664
 665 (define (operating-system-etc-directory os)
 666   "Return that static part of the /etc directory of OS."
 667   (etc-directory
 668    (fold-services (operating-system-services os)
 669                   #:target-type etc-service-type)))
 670
 671 (define (operating-system-environment-variables os)
 672   "Return the environment variables of OS for
 673 @var{session-environment-service-type}, to be used in @file{/etc/environment}."
 674   `(("LANG" . ,(operating-system-locale os))
 675     ("TZ" . ,(operating-system-timezone os))
 676     ("TZDIR" . ,(file-append tzdata "/share/zoneinfo"))
 677     ;; Tell 'modprobe' & co. where to look for modules.
 678     ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
 679     ;; These variables are honored by OpenSSL (libssl) and Git.
 680     ("SSL_CERT_DIR" . "/etc/ssl/certs")
 681     ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
 682     ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")
 683
 684     ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are
 685     ;; searched for.
 686     ("GTK_DATA_PREFIX" . "/run/current-system/profile")
 687
 688     ;; By default, applications that use D-Bus, such as Emacs, abort at startup
 689     ;; when /etc/machine-id is missing.  Make sure these warnings are non-fatal.
 690     ("DBUS_FATAL_WARNINGS" . "0")
 691
 692     ;; XXX: Normally we wouldn't need to do this, but our glibc@2.23 package
 693     ;; used to look things up in 'PREFIX/lib/locale' instead of
 694     ;; '/run/current-system/locale' as was intended.  Keep this hack around so
 695     ;; that people who still have glibc@2.23-using packages in their profiles
 696     ;; can use them correctly.
 697     ;; TODO: Remove when glibc@2.23 is long gone.
 698     ("GUIX_LOCPATH" . "/run/current-system/locale")))
 699
 700 (define %setuid-programs
 701   ;; Default set of setuid-root programs.
 702   (let ((shadow (@ (gnu packages admin) shadow)))
 703     (list (file-append shadow "/bin/passwd")
 704           (file-append shadow "/bin/su")
 705           (file-append inetutils "/bin/ping")
 706           (file-append inetutils "/bin/ping6")
 707           (file-append sudo "/bin/sudo")
 708           (file-append fuse "/bin/fusermount"))))
 709
 710 (define %sudoers-specification
 711   ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
 712   ;; group can do anything.  See
 713   ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
 714   ;; TODO: Add a declarative API.
 715   (plain-file "sudoers" "\
 716 root ALL=(ALL) ALL
 717 %wheel ALL=(ALL) ALL\n"))
 718
 719 (define* (operating-system-activation-script os #:key container?)
 720   "Return the activation script for OS---i.e., the code that \"activates\" the
 721 stateful part of OS, including user accounts and groups, special directories,
 722 etc."
 723   (let* ((services   (operating-system-services os #:container? container?))
 724          (activation (fold-services services
 725                                     #:target-type activation-service-type)))
 726     (activation-service->script activation)))
 727
 728 (define* (operating-system-boot-script os #:key container?)
 729   "Return the boot script for OS---i.e., the code started by the initrd once
 730 we're running in the final root.  When CONTAINER? is true, skip all
 731 hardware-related operations as necessary when booting a Linux container."
 732   (let* ((services (operating-system-services os #:container? container?))
 733          (boot     (fold-services services #:target-type boot-service-type)))
 734     ;; BOOT is the script as a monadic value.
 735     (service-value boot)))
 736
 737 (define (operating-system-user-accounts os)
 738   "Return the list of user accounts of OS."
 739   (let* ((services (operating-system-services os))
 740          (account  (fold-services services
 741                                   #:target-type account-service-type)))
 742     (filter user-account?
 743             (service-value account))))
 744
 745 (define (operating-system-shepherd-service-names os)
 746   "Return the list of Shepherd service names for OS."
 747   (append-map shepherd-service-provision
 748               (service-value
 749                (fold-services (operating-system-services os)
 750                               #:target-type
 751                               shepherd-root-service-type))))
 752
 753 (define* (operating-system-derivation os #:key container?)
 754   "Return a derivation that builds OS."
 755   (let* ((services (operating-system-services os #:container? container?))
 756          (system   (fold-services services)))
 757     ;; SYSTEM contains the derivation as a monadic value.
 758     (service-value system)))
 759
 760 (define* (operating-system-profile os #:key container?)
 761   "Return a derivation that builds the system profile of OS."
 762   (mlet* %store-monad
 763       ((services -> (operating-system-services os #:container? container?))
 764        (profile (fold-services services
 765                                #:target-type profile-service-type)))
 766     (match profile
 767       (("profile" profile)
 768        (return profile)))))
 769
 770 (define (operating-system-root-file-system os)
 771   "Return the root file system of OS."
 772   (find (match-lambda
 773          (($ <file-system> device title "/") #t)
 774          (x #f))
 775         (operating-system-file-systems os)))
 776
 777 (define (operating-system-initrd-file os)
 778   "Return a gexp denoting the initrd file of OS."
 779   (define boot-file-systems
 780     (filter file-system-needed-for-boot?
 781             (operating-system-file-systems os)))
 782
 783   (define mapped-devices
 784     (operating-system-boot-mapped-devices os))
 785
 786   (define make-initrd
 787     (operating-system-initrd os))
 788
 789   (mlet %store-monad ((initrd (make-initrd boot-file-systems
 790                                            #:linux (operating-system-kernel os)
 791                                            #:mapped-devices mapped-devices)))
 792     (return (file-append initrd "/initrd"))))
 793
 794 (define (locale-name->definition* name)
 795   "Variant of 'locale-name->definition' that raises an error upon failure."
 796   (match (locale-name->definition name)
 797     (#f
 798      (raise (condition
 799              (&message
 800               (message (format #f (G_ "~a: invalid locale name") name))))))
 801     (def def)))
 802
 803 (define (operating-system-locale-directory os)
 804   "Return the directory containing the locales compiled for the definitions
 805 listed in OS.  The C library expects to find it under
 806 /run/current-system/locale."
 807   (define name
 808     (operating-system-locale os))
 809
 810   (define definitions
 811     ;; While we're at it, check whether NAME is defined and add it if needed.
 812     (if (member name (map locale-definition-name
 813                           (operating-system-locale-definitions os)))
 814         (operating-system-locale-definitions os)
 815         (cons (locale-name->definition* name)
 816               (operating-system-locale-definitions os))))
 817
 818   (locale-directory definitions
 819                     #:libcs (operating-system-locale-libcs os)))
 820
 821 (define (kernel->boot-label kernel)
 822   "Return a label for the bootloader menu entry that boots KERNEL."
 823   (string-append "GNU with "
 824                  (string-titlecase (package-name kernel)) " "
 825                  (package-version kernel)
 826                  " (beta)"))
 827
 828 (define (store-file-system file-systems)
 829   "Return the file system object among FILE-SYSTEMS that contains the store."
 830   (match (filter (lambda (fs)
 831                    (and (file-system-mount? fs)
 832                         (not (memq 'bind-mount (file-system-flags fs)))
 833                         (string-prefix? (file-system-mount-point fs)
 834                                         (%store-prefix))))
 835                  file-systems)
 836     ((and candidates (head . tail))
 837      (reduce (lambda (fs1 fs2)
 838                (if (> (string-length (file-system-mount-point fs1))
 839                       (string-length (file-system-mount-point fs2)))
 840                    fs1
 841                    fs2))
 842              head
 843              candidates))))
 844
 845 (define (operating-system-store-file-system os)
 846   "Return the file system that contains the store of OS."
 847   (store-file-system (operating-system-file-systems os)))
 848
 849 (define* (operating-system-bootcfg os #:optional (old-entries '()))
 850   "Return the bootloader configuration file for OS.  Use OLD-ENTRIES to
 851 populate the \"old entries\" menu."
 852   (mlet* %store-monad
 853       ((system      (operating-system-derivation os))
 854        (root-fs ->  (operating-system-root-file-system os))
 855        (root-device -> (if (eq? 'uuid (file-system-title root-fs))
 856                            (uuid->string (file-system-device root-fs))
 857                            (file-system-device root-fs)))
 858        (entry (operating-system-boot-parameters os system root-device))
 859        (bootloader-conf -> (operating-system-bootloader os)))
 860     ((bootloader-configuration-file-generator
 861       (bootloader-configuration-bootloader bootloader-conf))
 862      bootloader-conf (list entry) #:old-entries old-entries)))
 863
 864 (define (fs->boot-device fs)
 865   "Given FS, a <file-system> object, return a value suitable for use as the
 866 device in a <menu-entry>."
 867   (case (file-system-title fs)
 868     ((uuid) (file-system-device fs))
 869     ((label) (file-system-device fs))
 870     (else #f)))
 871
 872 (define (operating-system-boot-parameters os system.drv root-device)
 873   "Return a monadic <boot-parameters> record that describes the boot parameters
 874 of OS.  SYSTEM.DRV is either a derivation or #f.  If it's a derivation, adds
 875 kernel arguments for that derivation to <boot-parameters>."
 876   (mlet* %store-monad
 877       ((initrd (operating-system-initrd-file os))
 878        (store -> (operating-system-store-file-system os))
 879        (bootloader  -> (bootloader-configuration-bootloader
 880                         (operating-system-bootloader os)))
 881        (boot-name   -> (bootloader-name bootloader))
 882        (label -> (kernel->boot-label (operating-system-kernel os))))
 883     (return (boot-parameters
 884              (label label)
 885              (root-device root-device)
 886              (kernel (operating-system-kernel-file os))
 887              (kernel-arguments
 888               (if system.drv
 889                 (operating-system-kernel-arguments os system.drv root-device)
 890                 (operating-system-user-kernel-arguments os)))
 891              (initrd initrd)
 892              (boot-name boot-name)
 893              (store-device (fs->boot-device store))
 894              (store-mount-point (file-system-mount-point store))))))
 895
 896 (define* (operating-system-boot-parameters-file os #:optional (system.drv #f))
 897    "Return a file that describes the boot parameters of OS.  The primary use of
 898 this file is the reconstruction of GRUB menu entries for old configurations.
 899 SYSTEM.DRV is optional.  If given, adds kernel arguments for that system to the
 900 returned file (since the returned file is then usually stored into the
 901 content-addressed \"system\" directory, it's usually not a good idea
 902 to give it because the content hash would change by the content hash
 903 being stored into the \"parameters\" file)."
 904   (mlet* %store-monad ((root -> (operating-system-root-file-system os))
 905                        (device -> (file-system-device root))
 906                        (params (operating-system-boot-parameters os
 907                                                                  system.drv
 908                                                                  device)))
 909      (gexp->file "parameters"
 910                  #~(boot-parameters
 911                     (version 0)
 912                     (label #$(boot-parameters-label params))
 913                     (root-device #$(boot-parameters-root-device params))
 914                     (kernel #$(boot-parameters-kernel params))
 915                     (kernel-arguments
 916                      #$(boot-parameters-kernel-arguments params))
 917                     (initrd #$(boot-parameters-initrd params))
 918                     (boot-name #$(boot-parameters-boot-name params))
 919                     (store
 920                      (device #$(boot-parameters-store-device params))
 921                      (mount-point #$(boot-parameters-store-mount-point params))))
 922                  #:set-load-path? #f)))
 923
 924 ;;; system.scm ends here