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          ;; temporary package to fix CVE-2018-7738 without a graft
 519          util-linux-2.31.1
 520          inetutils isc-dhcp
 521          (@ (gnu packages admin) shadow)          ;for 'passwd'
 522
 523          ;; wireless-tools is deprecated in favor of iw, but it's still what
 524          ;; many people are familiar with, so keep it around.
 525          iw wireless-tools
 526
 527          iproute
 528          net-tools                        ; XXX: remove when Inetutils suffices
 529          man-db
 530          info-reader                     ;the standalone Info reader (no Perl)
 531
 532          ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
 533          ;; want the other commands and the man pages (notably because
 534          ;; auto-completion in Emacs shell relies on man pages.)
 535          sudo
 536
 537          ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
 538          ;; already depends on it anyway.
 539          kmod eudev
 540
 541          e2fsprogs kbd
 542
 543          bash-completion
 544
 545          ;; XXX: We don't use (canonical-package guile-2.2) here because that
 546          ;; would create a collision in the global profile between the GMP
 547          ;; variant propagated by 'guile-final' and the GMP variant propagated
 548          ;; by 'gnutls', itself propagated by 'guix'.
 549          guile-2.2
 550
 551          ;; The packages below are also in %FINAL-INPUTS, so take them from
 552          ;; there to avoid duplication.
 553          (map canonical-package
 554               (list bash coreutils findutils grep sed
 555                     diffutils patch gawk tar gzip bzip2 xz lzip))))
 556
 557 (define %default-issue
 558   ;; Default contents for /etc/issue.
 559   "
 560 This is the GNU system.  Welcome.\n")
 561
 562 (define (local-host-aliases host-name)
 563   "Return aliases for HOST-NAME, to be used in /etc/hosts."
 564   (string-append "127.0.0.1 localhost " host-name "\n"
 565                  "::1       localhost " host-name "\n"))
 566
 567 (define (default-/etc/hosts host-name)
 568   "Return the default /etc/hosts file."
 569   (plain-file "hosts" (local-host-aliases host-name)))
 570
 571 (define* (operating-system-etc-service os)
 572   "Return a <service> that builds containing the static part of the /etc
 573 directory."
 574   (let ((login.defs (plain-file "login.defs" "# Empty for now.\n"))
 575
 576         (issue      (plain-file "issue" (operating-system-issue os)))
 577         (nsswitch   (plain-file "nsswitch.conf"
 578                                 (name-service-switch->string
 579                                  (operating-system-name-service-switch os))))
 580
 581         ;; Startup file for POSIX-compliant login shells, which set system-wide
 582         ;; environment variables.
 583         (profile    (mixed-text-file "profile"  "\
 584 # Crucial variables that could be missing in the profiles' 'etc/profile'
 585 # because they would require combining both profiles.
 586 # FIXME: See <http://bugs.gnu.org/20255>.
 587 export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man
 588 export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info
 589 export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share
 590 export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg
 591
 592 # Make sure libXcursor finds cursors installed into user or system profiles.  See <http://bugs.gnu.org/24445>
 593 export XCURSOR_PATH=$HOME/.icons:$HOME/.guix-profile/share/icons:/run/current-system/profile/share/icons
 594
 595 # Ignore the default value of 'PATH'.
 596 unset PATH
 597
 598 # Load the system profile's settings.
 599 GUIX_PROFILE=/run/current-system/profile ; \\
 600 . /run/current-system/profile/etc/profile
 601
 602 # Prepend setuid programs.
 603 export PATH=/run/setuid-programs:$PATH
 604
 605 # Since 'lshd' does not use pam_env, /etc/environment must be explicitly
 606 # loaded when someone logs in via SSH.  See <http://bugs.gnu.org/22175>.
 607 # We need 'PATH' to be defined here, for 'cat' and 'cut'.  Do this before
 608 # reading the user's 'etc/profile' to allow variables to be overridden.
 609 if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\
 610      -a -z \"$LINUX_MODULE_DIRECTORY\" ]
 611 then
 612   . /etc/environment
 613   export `cat /etc/environment | cut -d= -f1`
 614 fi
 615
 616 if [ -f \"$HOME/.guix-profile/etc/profile\" ]
 617 then
 618   # Load the user profile's settings.
 619   GUIX_PROFILE=\"$HOME/.guix-profile\" ; \\
 620   . \"$HOME/.guix-profile/etc/profile\"
 621 else
 622   # At least define this one so that basic things just work
 623   # when the user installs their first package.
 624   export PATH=\"$HOME/.guix-profile/bin:$PATH\"
 625 fi
 626
 627 # Set the umask, notably for users logging in via 'lsh'.
 628 # See <http://bugs.gnu.org/22650>.
 629 umask 022
 630
 631 # Allow Hunspell-based applications (IceCat, LibreOffice, etc.) to
 632 # find dictionaries.
 633 export DICPATH=\"$HOME/.guix-profile/share/hunspell:/run/current-system/profile/share/hunspell\"
 634
 635 # Allow GStreamer-based applications to find plugins.
 636 export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"
 637
 638 if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ]
 639 then
 640   # Load Bash-specific initialization code.
 641   . /etc/bashrc
 642 fi
 643 "))
 644
 645         (bashrc    (plain-file "bashrc" "\
 646 # Bash-specific initialization.
 647
 648 # The 'bash-completion' package.
 649 if [ -f /run/current-system/profile/etc/profile.d/bash_completion.sh ]
 650 then
 651   # Bash-completion sources ~/.bash_completion.  It installs a dynamic
 652   # completion loader that searches its own completion files as well
 653   # as those in ~/.guix-profile and /run/current-system/profile.
 654   source /run/current-system/profile/etc/profile.d/bash_completion.sh
 655 fi\n")))
 656     (etc-service
 657      `(("services" ,(file-append net-base "/etc/services"))
 658        ("protocols" ,(file-append net-base "/etc/protocols"))
 659        ("rpc" ,(file-append net-base "/etc/rpc"))
 660        ("login.defs" ,#~#$login.defs)
 661        ("issue" ,#~#$issue)
 662        ("nsswitch.conf" ,#~#$nsswitch)
 663        ("profile" ,#~#$profile)
 664        ("bashrc" ,#~#$bashrc)
 665        ("hosts" ,#~#$(or (operating-system-hosts-file os)
 666                          (default-/etc/hosts (operating-system-host-name os))))
 667        ;; Write the operating-system-host-name to /etc/hostname to prevent
 668        ;; NetworkManager from changing the system's hostname when connecting
 669        ;; to certain networks.  Some discussion at
 670        ;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html
 671        ("hostname" ,(plain-file "hostname" (operating-system-host-name os)))
 672        ("localtime" ,(file-append tzdata "/share/zoneinfo/"
 673                                   (operating-system-timezone os)))
 674        ("sudoers" ,(operating-system-sudoers-file os))))))
 675
 676 (define %root-account
 677   ;; Default root account.
 678   (user-account
 679    (name "root")
 680    (password "")
 681    (uid 0) (group "root")
 682    (comment "System administrator")
 683    (home-directory "/root")))
 684
 685 (define (operating-system-accounts os)
 686   "Return the user accounts for OS, including an obligatory 'root' account,
 687 and excluding accounts requested by services."
 688   ;; Make sure there's a root account.
 689   (if (find (lambda (user)
 690               (and=> (user-account-uid user) zero?))
 691             (operating-system-users os))
 692       (operating-system-users os)
 693       (cons %root-account (operating-system-users os))))
 694
 695 (define (maybe-string->file file-name thing)
 696   "If THING is a string, return a <plain-file> with THING as its content.
 697 Otherwise just return THING.
 698
 699 This is for backward-compatibility of fields that used to be strings and are
 700 now file-like objects.."
 701   (match thing
 702     ((? string?)
 703      (warning (G_ "using a string for file '~a' is deprecated; \
 704 use 'plain-file' instead~%")
 705               file-name)
 706      (plain-file file-name thing))
 707     (x
 708      x)))
 709
 710 (define (maybe-file->monadic file-name thing)
 711   "If THING is a value in %STORE-MONAD, return it as is; otherwise return
 712 THING in the %STORE-MONAD.
 713
 714 This is for backward-compatibility of fields that used to be monadic values
 715 and are now file-like objects."
 716   (with-monad %store-monad
 717     (match thing
 718       ((? procedure?)
 719        (warning (G_ "using a monadic value for '~a' is deprecated; \
 720 use 'plain-file' instead~%")
 721                 file-name)
 722        thing)
 723       (x
 724        (return x)))))
 725
 726 (define (operating-system-etc-directory os)
 727   "Return that static part of the /etc directory of OS."
 728   (etc-directory
 729    (fold-services (operating-system-services os)
 730                   #:target-type etc-service-type)))
 731
 732 (define (operating-system-environment-variables os)
 733   "Return the environment variables of OS for
 734 @var{session-environment-service-type}, to be used in @file{/etc/environment}."
 735   `(("LANG" . ,(operating-system-locale os))
 736     ;; Note: No need to set 'TZ' since (1) we provide /etc/localtime, and (2)
 737     ;; it doesn't work for setuid binaries.  See <https://bugs.gnu.org/29212>.
 738     ("TZDIR" . ,(file-append tzdata "/share/zoneinfo"))
 739     ;; Tell 'modprobe' & co. where to look for modules.
 740     ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
 741     ;; These variables are honored by OpenSSL (libssl) and Git.
 742     ("SSL_CERT_DIR" . "/etc/ssl/certs")
 743     ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
 744     ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")
 745
 746     ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are
 747     ;; searched for.
 748     ("GTK_DATA_PREFIX" . "/run/current-system/profile")
 749
 750     ;; By default, applications that use D-Bus, such as Emacs, abort at startup
 751     ;; when /etc/machine-id is missing.  Make sure these warnings are non-fatal.
 752     ("DBUS_FATAL_WARNINGS" . "0")
 753
 754     ;; XXX: Normally we wouldn't need to do this, but our glibc@2.23 package
 755     ;; used to look things up in 'PREFIX/lib/locale' instead of
 756     ;; '/run/current-system/locale' as was intended.  Keep this hack around so
 757     ;; that people who still have glibc@2.23-using packages in their profiles
 758     ;; can use them correctly.
 759     ;; TODO: Remove when glibc@2.23 is long gone.
 760     ("GUIX_LOCPATH" . "/run/current-system/locale")))
 761
 762 (define %setuid-programs
 763   ;; Default set of setuid-root programs.
 764   (let ((shadow (@ (gnu packages admin) shadow)))
 765     (list (file-append shadow "/bin/passwd")
 766           (file-append shadow "/bin/su")
 767           (file-append shadow "/bin/newuidmap")
 768           (file-append shadow "/bin/newgidmap")
 769           (file-append inetutils "/bin/ping")
 770           (file-append inetutils "/bin/ping6")
 771           (file-append sudo "/bin/sudo")
 772           (file-append fuse "/bin/fusermount"))))
 773
 774 (define %sudoers-specification
 775   ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
 776   ;; group can do anything.  See
 777   ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
 778   ;; TODO: Add a declarative API.
 779   (plain-file "sudoers" "\
 780 root ALL=(ALL) ALL
 781 %wheel ALL=(ALL) ALL\n"))
 782
 783 (define* (operating-system-activation-script os #:key container?)
 784   "Return the activation script for OS---i.e., the code that \"activates\" the
 785 stateful part of OS, including user accounts and groups, special directories,
 786 etc."
 787   (let* ((services   (operating-system-services os #:container? container?))
 788          (activation (fold-services services
 789                                     #:target-type activation-service-type)))
 790     (activation-service->script activation)))
 791
 792 (define* (operating-system-boot-script os #:key container?)
 793   "Return the boot script for OS---i.e., the code started by the initrd once
 794 we're running in the final root.  When CONTAINER? is true, skip all
 795 hardware-related operations as necessary when booting a Linux container."
 796   (let* ((services (operating-system-services os #:container? container?))
 797          (boot     (fold-services services #:target-type boot-service-type)))
 798     ;; BOOT is the script as a monadic value.
 799     (service-value boot)))
 800
 801 (define (operating-system-user-accounts os)
 802   "Return the list of user accounts of OS."
 803   (let* ((services (operating-system-services os))
 804          (account  (fold-services services
 805                                   #:target-type account-service-type)))
 806     (filter user-account?
 807             (service-value account))))
 808
 809 (define (operating-system-shepherd-service-names os)
 810   "Return the list of Shepherd service names for OS."
 811   (append-map shepherd-service-provision
 812               (service-value
 813                (fold-services (operating-system-services os)
 814                               #:target-type
 815                               shepherd-root-service-type))))
 816
 817 (define* (operating-system-derivation os #:key container?)
 818   "Return a derivation that builds OS."
 819   (let* ((services (operating-system-services os #:container? container?))
 820          (system   (fold-services services)))
 821     ;; SYSTEM contains the derivation as a monadic value.
 822     (service-value system)))
 823
 824 (define* (operating-system-profile os #:key container?)
 825   "Return a derivation that builds the system profile of OS."
 826   (mlet* %store-monad
 827       ((services -> (operating-system-services os #:container? container?))
 828        (profile (fold-services services
 829                                #:target-type profile-service-type)))
 830     (match profile
 831       (("profile" profile)
 832        (return profile)))))
 833
 834 (define (operating-system-root-file-system os)
 835   "Return the root file system of OS."
 836   (find (match-lambda
 837          (($ <file-system> device title "/") #t)
 838          (x #f))
 839         (operating-system-file-systems os)))
 840
 841 (define (operating-system-initrd-file os)
 842   "Return a gexp denoting the initrd file of OS."
 843   (define boot-file-systems
 844     (filter file-system-needed-for-boot?
 845             (operating-system-file-systems os)))
 846
 847   (define mapped-devices
 848     (operating-system-boot-mapped-devices os))
 849
 850   (define make-initrd
 851     (operating-system-initrd os))
 852
 853   (mlet %store-monad ((initrd (make-initrd boot-file-systems
 854                                            #:linux (operating-system-kernel os)
 855                                            #:linux-modules
 856                                            (operating-system-initrd-modules os)
 857                                            #:mapped-devices mapped-devices)))
 858     (return (file-append initrd "/initrd"))))
 859
 860 (define (locale-name->definition* name)
 861   "Variant of 'locale-name->definition' that raises an error upon failure."
 862   (match (locale-name->definition name)
 863     (#f
 864      (raise (condition
 865              (&message
 866               (message (format #f (G_ "~a: invalid locale name") name))))))
 867     (def def)))
 868
 869 (define (operating-system-locale-directory os)
 870   "Return the directory containing the locales compiled for the definitions
 871 listed in OS.  The C library expects to find it under
 872 /run/current-system/locale."
 873   (define name
 874     (operating-system-locale os))
 875
 876   (define definitions
 877     ;; While we're at it, check whether NAME is defined and add it if needed.
 878     (if (member name (map locale-definition-name
 879                           (operating-system-locale-definitions os)))
 880         (operating-system-locale-definitions os)
 881         (cons (locale-name->definition* name)
 882               (operating-system-locale-definitions os))))
 883
 884   (locale-directory definitions
 885                     #:libcs (operating-system-locale-libcs os)))
 886
 887 (define (kernel->boot-label kernel)
 888   "Return a label for the bootloader menu entry that boots KERNEL."
 889   (string-append "GNU with "
 890                  (string-titlecase (package-name kernel)) " "
 891                  (package-version kernel)
 892                  " (beta)"))
 893
 894 (define (store-file-system file-systems)
 895   "Return the file system object among FILE-SYSTEMS that contains the store."
 896   (match (filter (lambda (fs)
 897                    (and (file-system-mount? fs)
 898                         (not (memq 'bind-mount (file-system-flags fs)))
 899                         (string-prefix? (file-system-mount-point fs)
 900                                         (%store-prefix))))
 901                  file-systems)
 902     ((and candidates (head . tail))
 903      (reduce (lambda (fs1 fs2)
 904                (if (> (string-length (file-system-mount-point fs1))
 905                       (string-length (file-system-mount-point fs2)))
 906                    fs1
 907                    fs2))
 908              head
 909              candidates))))
 910
 911 (define (operating-system-store-file-system os)
 912   "Return the file system that contains the store of OS."
 913   (store-file-system (operating-system-file-systems os)))
 914
 915 (define* (operating-system-bootcfg os #:optional (old-entries '()))
 916   "Return the bootloader configuration file for OS.  Use OLD-ENTRIES
 917 (which is a list of <menu-entry>) to populate the \"old entries\" menu."
 918   (mlet* %store-monad
 919       ((system      (operating-system-derivation os))
 920        (root-fs ->  (operating-system-root-file-system os))
 921        (root-device -> (file-system-device root-fs))
 922        (params (operating-system-boot-parameters os system root-device))
 923        (entry -> (boot-parameters->menu-entry params))
 924        (bootloader-conf -> (operating-system-bootloader os)))
 925     ((bootloader-configuration-file-generator
 926       (bootloader-configuration-bootloader bootloader-conf))
 927      bootloader-conf (list entry) #:old-entries old-entries)))
 928
 929 (define (fs->boot-device fs)
 930   "Given FS, a <file-system> object, return a value suitable for use as the
 931 device in a <menu-entry>."
 932   (case (file-system-title fs)
 933     ((uuid label device) (file-system-device fs))
 934     (else #f)))
 935
 936 (define (operating-system-boot-parameters os system.drv root-device)
 937   "Return a monadic <boot-parameters> record that describes the boot parameters
 938 of OS.  SYSTEM.DRV is either a derivation or #f.  If it's a derivation, adds
 939 kernel arguments for that derivation to <boot-parameters>."
 940   (mlet* %store-monad
 941       ((initrd (operating-system-initrd-file os))
 942        (store -> (operating-system-store-file-system os))
 943        (bootloader  -> (bootloader-configuration-bootloader
 944                         (operating-system-bootloader os)))
 945        (bootloader-name -> (bootloader-name bootloader))
 946        (label -> (kernel->boot-label (operating-system-kernel os))))
 947     (return (boot-parameters
 948              (label label)
 949              (root-device root-device)
 950              (kernel (operating-system-kernel-file os))
 951              (kernel-arguments
 952               (if system.drv
 953                 (operating-system-kernel-arguments os system.drv root-device)
 954                 (operating-system-user-kernel-arguments os)))
 955              (initrd initrd)
 956              (bootloader-name bootloader-name)
 957              (store-device (ensure-not-/dev (fs->boot-device store)))
 958              (store-mount-point (file-system-mount-point store))))))
 959
 960 (define (device->sexp device)
 961   "Serialize DEVICE as an sexp (really, as an object with a read syntax.)"
 962   (match device
 963     ((? uuid? uuid)
 964      `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))
 965     (_
 966      device)))
 967
 968 (define* (operating-system-boot-parameters-file os #:optional (system.drv #f))
 969    "Return a file that describes the boot parameters of OS.  The primary use of
 970 this file is the reconstruction of GRUB menu entries for old configurations.
 971 SYSTEM.DRV is optional.  If given, adds kernel arguments for that system to the
 972 returned file (since the returned file is then usually stored into the
 973 content-addressed \"system\" directory, it's usually not a good idea
 974 to give it because the content hash would change by the content hash
 975 being stored into the \"parameters\" file)."
 976   (mlet* %store-monad ((root -> (operating-system-root-file-system os))
 977                        (device -> (file-system-device root))
 978                        (params (operating-system-boot-parameters os
 979                                                                  system.drv
 980                                                                  device)))
 981      (gexp->file "parameters"
 982                  #~(boot-parameters
 983                     (version 0)
 984                     (label #$(boot-parameters-label params))
 985                     (root-device
 986                      #$(device->sexp
 987                         (boot-parameters-root-device params)))
 988                     (kernel #$(boot-parameters-kernel params))
 989                     (kernel-arguments
 990                      #$(boot-parameters-kernel-arguments params))
 991                     (initrd #$(boot-parameters-initrd params))
 992                     (bootloader-name #$(boot-parameters-bootloader-name params))
 993                     (store
 994                      (device
 995                       #$(device->sexp (boot-parameters-store-device params)))
 996                      (mount-point #$(boot-parameters-store-mount-point params))))
 997                  #:set-load-path? #f)))
 998
 999 (define-gexp-compiler (operating-system-compiler (os <operating-system>)
1000                                                  system target)
1001   ((store-lift
1002     (lambda (store)
1003       ;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to
1004       ;; 'operating-system-derivation'.
1005       (run-with-store store (operating-system-derivation os)
1006                       #:system system
1007                       #:target target)))))
1008
1009 ;;; system.scm ends here