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