gnu/system.scm

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