;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Meiyo Peng <meiyo.peng@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system)
+ #:use-module (guix inferior)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix gexp)
operating-system-kernel
operating-system-kernel-file
operating-system-kernel-arguments
+ operating-system-initrd-modules
operating-system-initrd
operating-system-users
operating-system-groups
operating-system-activation-script
operating-system-user-accounts
operating-system-shepherd-service-names
+ operating-system-user-kernel-arguments
operating-system-derivation
operating-system-profile
boot-parameters->menu-entry
local-host-aliases
+ %root-account
%setuid-programs
%base-packages
%base-firmware))
;;;
;;; Code:
-(define (bootable-kernel-arguments kernel-arguments system.drv root-device)
- "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))
- #~(string-append "--system=" #$system.drv)
- #~(string-append "--load=" #$system.drv "/boot")
- kernel-arguments))
+(define (bootable-kernel-arguments system root-device)
+ "Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE."
+ (list (string-append "--root="
+ (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)
+ #~(string-append "--load=" #$system "/boot")))
;; System-wide configuration.
;; TODO: Add per-field docstrings/stexi.
(default '())) ; list of gexps/strings
(bootloader operating-system-bootloader) ; <bootloader-configuration>
- (initrd operating-system-initrd ; (list fs) -> M derivation
+ (initrd operating-system-initrd ; (list fs) -> file-like
(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))
(sudoers-file operating-system-sudoers-file ; file-like
(default %sudoers-specification)))
-(define (operating-system-kernel-arguments os system.drv root-device)
+(define (operating-system-kernel-arguments os root-device)
"Return all the kernel arguments, including the ones not specified
directly by the user."
- (bootable-kernel-arguments (operating-system-user-kernel-arguments os)
- system.drv
- root-device))
+ (append (bootable-kernel-arguments os root-device)
+ (operating-system-user-kernel-arguments os)))
\f
;;;
(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)
(_ ;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)
The object has its kernel-arguments extended in order to make it bootable."
(let* ((file (string-append system "/parameters"))
(params (call-with-input-file file read-boot-parameters))
- (root (boot-parameters-root-device params))
- (kernel-arguments (boot-parameters-kernel-arguments params)))
- (if params
- (boot-parameters
- (inherit params)
- (kernel-arguments (bootable-kernel-arguments kernel-arguments
- system root)))
- #f)))
+ (root (boot-parameters-root-device params)))
+ (boot-parameters
+ (inherit params)
+ (kernel-arguments (append (bootable-kernel-arguments system root)
+ (boot-parameters-kernel-arguments params))))))
(define (boot-parameters->menu-entry conf)
(menu-entry
(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
(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
(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)
(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)
(return `(("locale" ,locale)))
(mlet %store-monad
((kernel -> (operating-system-kernel os))
- (initrd (operating-system-initrd-file os))
+ (initrd -> (operating-system-initrd-file os))
(params (operating-system-boot-parameters-file os)))
(return `(("kernel" ,kernel)
("parameters" ,params)
(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)
(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
;; Add the firmware service, unless we are building for a
;; container.
(if container?
- '()
+ (list %containerized-shepherd-service)
(list %linux-bare-metal-service
(service firmware-service-type
(operating-system-firmware os))))))))
(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?))))
\f
;;;
;; required for basic administrator tasks.
(cons* procps psmisc which less zile nano
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
(define* (operating-system-etc-service os)
"Return a <service> 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"
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 <http://bugs.gnu.org/22175>.
# We need 'PATH' to be defined here, for 'cat' and 'cut'. Do this before
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 <http://bugs.gnu.org/22650>.
(file-append inetutils "/bin/ping")
(file-append inetutils "/bin/ping6")
(file-append sudo "/bin/sudo")
+ (file-append sudo "/bin/sudoedit")
(file-append fuse "/bin/fusermount"))))
(define %sudoers-specification
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)
(define (operating-system-root-file-system os)
"Return the root file system of OS."
- (find (match-lambda
- (($ <file-system> 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)
(define make-initrd
(operating-system-initrd os))
- (mlet %store-monad ((initrd (make-initrd boot-file-systems
- #:linux (operating-system-kernel os)
- #:mapped-devices mapped-devices)))
- (return (file-append initrd "/initrd"))))
+ (make-initrd boot-file-systems
+ #:linux (operating-system-kernel os)
+ #:linux-modules
+ (operating-system-initrd-modules os)
+ #:mapped-devices mapped-devices))
(define (locale-name->definition* name)
"Variant of 'locale-name->definition' that raises an error upon failure."
(define (kernel->boot-label kernel)
"Return a label for the bootloader menu entry that boots KERNEL."
- (string-append "GNU with "
- (string-titlecase (package-name kernel)) " "
- (package-version kernel)
- " (beta)"))
+ (cond ((package? kernel)
+ (string-append "GNU with "
+ (string-titlecase (package-name kernel)) " "
+ (package-version kernel)
+ " (beta)"))
+ ((inferior-package? kernel)
+ (string-append "GNU with "
+ (string-titlecase (inferior-package-name kernel)) " "
+ (inferior-package-version kernel)
+ " (beta)"))
+ (else "GNU")))
(define (store-file-system file-systems)
"Return the file system object among FILE-SYSTEMS that contains the store."
(store-file-system (operating-system-file-systems os)))
(define* (operating-system-bootcfg os #:optional (old-entries '()))
- "Return the bootloader configuration file for OS. Use OLD-ENTRIES
-(which is a list of <menu-entry>) to populate the \"old entries\" menu."
- (mlet* %store-monad
- ((system (operating-system-derivation os))
- (root-fs -> (operating-system-root-file-system os))
- (root-device -> (file-system-device root-fs))
- (params (operating-system-boot-parameters os system root-device))
- (entry -> (boot-parameters->menu-entry params))
- (bootloader-conf -> (operating-system-bootloader os)))
- ((bootloader-configuration-file-generator
- (bootloader-configuration-bootloader bootloader-conf))
- bootloader-conf (list entry) #:old-entries old-entries)))
-
-(define (fs->boot-device fs)
- "Given FS, a <file-system> object, return a value suitable for use as the
-device in a <menu-entry>."
- (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 <boot-parameters> record that describes the boot parameters
-of OS. SYSTEM.DRV is either a derivation or #f. If it's a derivation, adds
-kernel arguments for that derivation to <boot-parameters>."
- (mlet* %store-monad
- ((initrd (operating-system-initrd-file os))
- (store -> (operating-system-store-file-system os))
- (bootloader -> (bootloader-configuration-bootloader
- (operating-system-bootloader os)))
- (bootloader-name -> (bootloader-name bootloader))
- (label -> (kernel->boot-label (operating-system-kernel os))))
- (return (boot-parameters
- (label label)
- (root-device root-device)
- (kernel (operating-system-kernel-file os))
- (kernel-arguments
- (if system.drv
- (operating-system-kernel-arguments os system.drv root-device)
- (operating-system-user-kernel-arguments os)))
- (initrd initrd)
- (bootloader-name bootloader-name)
- (store-device (ensure-not-/dev (fs->boot-device store)))
- (store-mount-point (file-system-mount-point store))))))
+ "Return the bootloader configuration file for OS. Use OLD-ENTRIES,
+a list of <menu-entry>, to populate the \"old entries\" menu."
+ (let* ((root-fs (operating-system-root-file-system os))
+ (root-device (file-system-device root-fs))
+ (params (operating-system-boot-parameters
+ os root-device
+ #:system-kernel-arguments? #t))
+ (entry (boot-parameters->menu-entry params))
+ (bootloader-conf (operating-system-bootloader os)))
+ (define generate-config-file
+ (bootloader-configuration-file-generator
+ (bootloader-configuration-bootloader bootloader-conf)))
+
+ (generate-config-file bootloader-conf (list entry)
+ #:old-entries old-entries)))
+
+(define* (operating-system-boot-parameters os root-device
+ #:key system-kernel-arguments?)
+ "Return a monadic <boot-parameters> record that describes the boot
+parameters of OS. When SYSTEM-KERNEL-ARGUMENTS? is true, add kernel arguments
+such as '--root' and '--load' to <boot-parameters>."
+ (let* ((initrd (operating-system-initrd-file os))
+ (store (operating-system-store-file-system os))
+ (bootloader (bootloader-configuration-bootloader
+ (operating-system-bootloader os)))
+ (bootloader-name (bootloader-name bootloader))
+ (label (kernel->boot-label (operating-system-kernel os))))
+ (boot-parameters
+ (label label)
+ (root-device root-device)
+ (kernel (operating-system-kernel-file os))
+ (kernel-arguments
+ (if system-kernel-arguments?
+ (operating-system-kernel-arguments os root-device)
+ (operating-system-user-kernel-arguments os)))
+ (initrd initrd)
+ (bootloader-name bootloader-name)
+ (store-device (ensure-not-/dev (file-system-device store)))
+ (store-mount-point (file-system-mount-point store)))))
(define (device->sexp device)
"Serialize DEVICE as an sexp (really, as an object with a read syntax.)"
(match device
((? uuid? uuid)
`(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))
+ ((? file-system-label? label)
+ `(file-system-label ,(file-system-label->string label)))
(_
device)))
-(define* (operating-system-boot-parameters-file os #:optional (system.drv #f))
+(define* (operating-system-boot-parameters-file os
+ #:key system-kernel-arguments?)
"Return a file that describes the boot parameters of OS. The primary use of
this file is the reconstruction of GRUB menu entries for old configurations.
-SYSTEM.DRV is optional. If given, adds kernel arguments for that system to the
-returned file (since the returned file is then usually stored into the
-content-addressed \"system\" directory, it's usually not a good idea
-to give it because the content hash would change by the content hash
+
+When SYSTEM-KERNEL-ARGUMENTS? is true, add kernel arguments such as '--root'
+and '--load' to the returned file (since the returned file is then usually
+stored into the content-addressed \"system\" directory, it's usually not a
+good idea to give it because the content hash would change by the content hash
being stored into the \"parameters\" file)."
- (mlet* %store-monad ((root -> (operating-system-root-file-system os))
- (device -> (file-system-device root))
- (params (operating-system-boot-parameters os
- system.drv
- device)))
+ (let* ((root (operating-system-root-file-system os))
+ (device (file-system-device root))
+ (params (operating-system-boot-parameters
+ os device
+ #:system-kernel-arguments?
+ system-kernel-arguments?)))
(gexp->file "parameters"
#~(boot-parameters
(version 0)
HCoop / jackhill / guix / guix.git / blobdiff