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