X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/ad3a937dae2586aa5a66ceed32a1c2005ee486c9..0058888c7efe4063f80180ff446513869420423f:/gnu/system.scm diff --git a/gnu/system.scm b/gnu/system.scm index 0e834ba5ed..e4a57475a9 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015, 2016 Alex Kost ;;; Copyright © 2016 Chris Marusich @@ -39,7 +39,6 @@ #:use-module (gnu packages less) #:use-module (gnu packages zile) #:use-module (gnu packages nano) - #:use-module (gnu packages lsof) #:use-module (gnu packages gawk) #:use-module (gnu packages man) #:use-module (gnu packages texinfo) @@ -75,6 +74,7 @@ operating-system-kernel operating-system-kernel-file operating-system-kernel-arguments + operating-system-initrd-modules operating-system-initrd operating-system-users operating-system-groups @@ -91,6 +91,7 @@ operating-system-activation-script operating-system-user-accounts operating-system-shepherd-service-names + operating-system-user-kernel-arguments operating-system-derivation operating-system-profile @@ -130,13 +131,16 @@ "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be booted from ROOT-DEVICE" (cons* (string-append "--root=" - (if (uuid? root-device) - - ;; Note: Always use the DCE format because that's - ;; what (gnu build linux-boot) expects for the - ;; '--root' kernel command-line option. - (uuid->string (uuid-bytevector root-device) 'dce) - root-device)) + (cond ((uuid? root-device) + + ;; Note: Always use the DCE format because that's + ;; what (gnu build linux-boot) expects for the + ;; '--root' kernel command-line option. + (uuid->string (uuid-bytevector root-device) + 'dce)) + ((file-system-label? root-device) + (file-system-label->string root-device)) + (else root-device))) #~(string-append "--system=" #$system.drv) #~(string-append "--load=" #$system.drv "/boot") kernel-arguments)) @@ -154,6 +158,10 @@ booted from ROOT-DEVICE" (initrd operating-system-initrd ; (list fs) -> M derivation (default base-initrd)) + (initrd-modules operating-system-initrd-modules ; list of strings + (thunked) ; it's system-dependent + (default %base-initrd-modules)) + (firmware operating-system-firmware ; list of packages (default %base-firmware)) @@ -246,10 +254,16 @@ file system labels." (match-lambda (('uuid (? symbol? type) (? bytevector? bv)) (bytevector->uuid bv type)) + (('file-system-label (? string? label)) + (file-system-label label)) ((? bytevector? bv) ;old format (bytevector->uuid bv 'dce)) ((? string? device) - device))) + ;; It used to be that we would not distinguish between labels and + ;; device names. Try to infer the right thing here. + (if (string-prefix? "/dev/" device) + device + (file-system-label device))))) (match (read port) (('boot-parameters ('version 0) @@ -303,8 +317,8 @@ file system labels." (_ ;the old format "/"))))) (x ;unsupported format - (warning (G_ "unrecognized boot parameters for '~a'~%") - system) + (warning (G_ "unrecognized boot parameters at '~a'~%") + (port-filename port)) #f))) (define (read-boot-parameters-file system) @@ -345,6 +359,9 @@ marked as 'needed-for-boot'." (remove file-system-needed-for-boot? (operating-system-file-systems os))) + (define mapped-devices-for-boot + (operating-system-boot-mapped-devices os)) + (define (device-mappings fs) (let ((device (file-system-device fs))) (if (string? device) ;title is 'device @@ -360,21 +377,23 @@ marked as 'needed-for-boot'." (file-system (inherit fs) (dependencies - (delete-duplicates (append (device-mappings fs) - (file-system-dependencies fs)) - eq?)))) + (delete-duplicates + (remove (cut member <> mapped-devices-for-boot) + (append (device-mappings fs) + (file-system-dependencies fs))) + eq?)))) (service file-system-service-type (map add-dependencies file-systems))) -(define (mapped-device-user device file-systems) - "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f." +(define (mapped-device-users device file-systems) + "Return the subset of FILE-SYSTEMS that use DEVICE." (let ((target (string-append "/dev/mapper/" (mapped-device-target device)))) - (find (lambda (fs) - (or (member device (file-system-dependencies fs)) - (and (eq? 'device (file-system-title fs)) - (string=? (file-system-device fs) target)))) - file-systems))) + (filter (lambda (fs) + (or (member device (file-system-dependencies fs)) + (and (string? (file-system-device fs)) + (string=? (file-system-device fs) target)))) + file-systems))) (define (operating-system-user-mapped-devices os) "Return the subset of mapped devices that can be installed in @@ -382,9 +401,8 @@ user-land--i.e., those not needed during boot." (let ((devices (operating-system-mapped-devices os)) (file-systems (operating-system-file-systems os))) (filter (lambda (md) - (let ((user (mapped-device-user md file-systems))) - (or (not user) - (not (file-system-needed-for-boot? user))))) + (let ((users (mapped-device-users md file-systems))) + (not (any file-system-needed-for-boot? users)))) devices))) (define (operating-system-boot-mapped-devices os) @@ -393,8 +411,8 @@ from the initrd." (let ((devices (operating-system-mapped-devices os)) (file-systems (operating-system-file-systems os))) (filter (lambda (md) - (let ((user (mapped-device-user md file-systems))) - (and user (file-system-needed-for-boot? user)))) + (let ((users (mapped-device-users md file-systems))) + (any file-system-needed-for-boot? users))) devices))) (define (device-mapping-services os) @@ -448,22 +466,21 @@ a container or that of a \"bare metal\" system." (let* ((mappings (device-mapping-services os)) (root-fs (root-file-system-service)) (other-fs (non-boot-file-system-service os)) - (unmount (user-unmount-service known-fs)) (swaps (swap-services os)) - (procs (user-processes-service)) + (procs (service user-processes-service-type)) (host-name (host-name-service (operating-system-host-name os))) (entries (operating-system-directory-base-entries os #:container? container?))) (cons* (service system-service-type entries) %boot-service - ;; %SHEPHERD-ROOT-SERVICE must come first so that the gexp that + ;; %SHEPHERD-ROOT-SERVICE must come last so that the gexp that ;; execs shepherd comes last in the boot script (XXX). Likewise, - ;; the cleanup service must come last so that its gexp runs before + ;; the cleanup service must come first so that its gexp runs before ;; activation code. - %shepherd-root-service - %activation-service (service cleanup-service-type #f) + %activation-service + %shepherd-root-service (pam-root-service (operating-system-pam-services os)) (account-service (append (operating-system-accounts os) @@ -473,7 +490,7 @@ a container or that of a \"bare metal\" system." (service fstab-service-type '()) (session-environment-service (operating-system-environment-variables os)) - host-name procs root-fs unmount + host-name procs root-fs (service setuid-program-service-type (operating-system-setuid-programs os)) (service profile-service-type @@ -492,8 +509,9 @@ a container or that of a \"bare metal\" system." (define* (operating-system-services os #:key container?) "Return all the services of OS, including \"internal\" services that do not explicitly appear in OS." - (append (operating-system-user-services os) - (essential-services os #:container? container?))) + (instantiate-missing-services + (append (operating-system-user-services os) + (essential-services os #:container? container?)))) ;;; @@ -509,14 +527,14 @@ explicitly appear in OS." ;; Default set of packages globally visible. It should include anything ;; required for basic administrator tasks. (cons* procps psmisc which less zile nano - lsof ;for Guix's 'list-runtime-roots' pciutils usbutils - util-linux inetutils isc-dhcp + util-linux + inetutils isc-dhcp (@ (gnu packages admin) shadow) ;for 'passwd' ;; wireless-tools is deprecated in favor of iw, but it's still what ;; many people are familiar with, so keep it around. - iw wireless-tools rfkill + iw wireless-tools iproute net-tools ; XXX: remove when Inetutils suffices @@ -565,7 +583,16 @@ This is the GNU system. Welcome.\n") (define* (operating-system-etc-service os) "Return a that builds containing the static part of the /etc directory." - (let ((login.defs (plain-file "login.defs" "# Empty for now.\n")) + (let ((login.defs + (plain-file "login.defs" + (string-append + "# Default paths for non-login shells started by su(1).\n" + "ENV_PATH /run/setuid-programs:" + "/run/current-system/profile/bin:" + "/run/current-system/profile/sbin\n" + "ENV_SUPATH /run/setuid-programs:" + "/run/current-system/profile/bin:" + "/run/current-system/profile/sbin\n"))) (issue (plain-file "issue" (operating-system-issue os))) (nsswitch (plain-file "nsswitch.conf" @@ -583,16 +610,16 @@ export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg +# Make sure libXcursor finds cursors installed into user or system profiles. See +export XCURSOR_PATH=$HOME/.icons:$HOME/.guix-profile/share/icons:/run/current-system/profile/share/icons + # Ignore the default value of 'PATH'. unset PATH # Load the system profile's settings. -GUIX_PROFILE=/run/current-system/profile \\ +GUIX_PROFILE=/run/current-system/profile ; \\ . /run/current-system/profile/etc/profile -# Prepend setuid programs. -export PATH=/run/setuid-programs:$PATH - # Since 'lshd' does not use pam_env, /etc/environment must be explicitly # loaded when someone logs in via SSH. See . # We need 'PATH' to be defined here, for 'cat' and 'cut'. Do this before @@ -604,16 +631,26 @@ then export `cat /etc/environment | cut -d= -f1` fi -if [ -f \"$HOME/.guix-profile/etc/profile\" ] -then - # Load the user profile's settings. - GUIX_PROFILE=\"$HOME/.guix-profile\" \\ - . \"$HOME/.guix-profile/etc/profile\" -else - # At least define this one so that basic things just work - # when the user installs their first package. - export PATH=\"$HOME/.guix-profile/bin:$PATH\" -fi +# Arrange so that ~/.config/guix/current comes first. +for profile in \"$HOME/.guix-profile\" \"$HOME/.config/guix/current\" +do + if [ -f \"$profile/etc/profile\" ] + then + # Load the user profile's settings. + GUIX_PROFILE=\"$profile\" ; \\ + . \"$profile/etc/profile\" + else + # At least define this one so that basic things just work + # when the user installs their first package. + export PATH=\"$profile/bin:$PATH\" + fi +done + +# Prepend setuid programs. +export PATH=/run/setuid-programs:$PATH + +# Arrange so that ~/.config/guix/current/share/info comes first. +export INFOPATH=\"$HOME/.config/guix/current/share/info:$INFOPATH\" # Set the umask, notably for users logging in via 'lsh'. # See . @@ -724,7 +761,8 @@ use 'plain-file' instead~%") "Return the environment variables of OS for @var{session-environment-service-type}, to be used in @file{/etc/environment}." `(("LANG" . ,(operating-system-locale os)) - ("TZ" . ,(operating-system-timezone os)) + ;; Note: No need to set 'TZ' since (1) we provide /etc/localtime, and (2) + ;; it doesn't work for setuid binaries. See . ("TZDIR" . ,(file-append tzdata "/share/zoneinfo")) ;; Tell 'modprobe' & co. where to look for modules. ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules") @@ -785,7 +823,6 @@ we're running in the final root. When CONTAINER? is true, skip all hardware-related operations as necessary when booting a Linux container." (let* ((services (operating-system-services os #:container? container?)) (boot (fold-services services #:target-type boot-service-type))) - ;; BOOT is the script as a monadic value. (service-value boot))) (define (operating-system-user-accounts os) @@ -823,9 +860,8 @@ hardware-related operations as necessary when booting a Linux container." (define (operating-system-root-file-system os) "Return the root file system of OS." - (find (match-lambda - (($ device title "/") #t) - (x #f)) + (find (lambda (fs) + (string=? "/" (file-system-mount-point fs))) (operating-system-file-systems os))) (define (operating-system-initrd-file os) @@ -842,6 +878,8 @@ hardware-related operations as necessary when booting a Linux container." (mlet %store-monad ((initrd (make-initrd boot-file-systems #:linux (operating-system-kernel os) + #:linux-modules + (operating-system-initrd-modules os) #:mapped-devices mapped-devices))) (return (file-append initrd "/initrd")))) @@ -914,13 +952,6 @@ listed in OS. The C library expects to find it under (bootloader-configuration-bootloader bootloader-conf)) bootloader-conf (list entry) #:old-entries old-entries))) -(define (fs->boot-device fs) - "Given FS, a object, return a value suitable for use as the -device in a ." - (case (file-system-title fs) - ((uuid label device) (file-system-device fs)) - (else #f))) - (define (operating-system-boot-parameters os system.drv root-device) "Return a monadic record that describes the boot parameters of OS. SYSTEM.DRV is either a derivation or #f. If it's a derivation, adds @@ -942,7 +973,7 @@ kernel arguments for that derivation to ." (operating-system-user-kernel-arguments os))) (initrd initrd) (bootloader-name bootloader-name) - (store-device (ensure-not-/dev (fs->boot-device store))) + (store-device (ensure-not-/dev (file-system-device store))) (store-mount-point (file-system-mount-point store)))))) (define (device->sexp device) @@ -950,6 +981,8 @@ kernel arguments for that derivation to ." (match device ((? uuid? uuid) `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid))) + ((? file-system-label? label) + `(file-system-label ,(file-system-label->string label))) (_ device)))