X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/ac3c14fb0712b0672a4a237dc9d267ee148597fe..7e93817dfb021ab0bf881bacc5e028e2becbc6da:/gnu/system.scm diff --git a/gnu/system.scm b/gnu/system.scm index 6bccdaa8c2..abdbb081e6 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, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015, 2016 Alex Kost ;;; Copyright © 2016 Chris Marusich @@ -34,6 +34,7 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages guile) + #:use-module (gnu packages guile-xyz) #:use-module (gnu packages admin) #:use-module (gnu packages linux) #:use-module (gnu packages pciutils) @@ -66,9 +67,12 @@ #:use-module (rnrs bytevectors) #:export (operating-system operating-system? + this-operating-system operating-system-bootloader operating-system-services + operating-system-essential-services + operating-system-default-essential-services operating-system-user-services operating-system-packages operating-system-host-name @@ -76,6 +80,8 @@ operating-system-kernel operating-system-kernel-file operating-system-kernel-arguments + operating-system-label + operating-system-default-label operating-system-initrd-modules operating-system-initrd operating-system-users @@ -103,12 +109,15 @@ operating-system-boot-script system-linux-image-file-name + operating-system-with-gc-roots + operating-system-with-provenance boot-parameters boot-parameters? boot-parameters-label boot-parameters-root-device boot-parameters-bootloader-name + boot-parameters-bootloader-menu-entries boot-parameters-store-device boot-parameters-store-mount-point boot-parameters-kernel @@ -151,12 +160,19 @@ (define-record-type* operating-system make-operating-system operating-system? + this-operating-system + (kernel operating-system-kernel ; package (default linux-libre)) (kernel-arguments operating-system-user-kernel-arguments - (default '())) ; list of gexps/strings + (default '("quiet"))) ; list of gexps/strings (bootloader operating-system-bootloader) ; + (label operating-system-label ; string + (thunked) + (default (operating-system-default-label this-operating-system))) + (keyboard-layout operating-system-keyboard-layout ;#f | + (default #f)) (initrd operating-system-initrd ; (list fs) -> file-like (default base-initrd)) (initrd-modules operating-system-initrd-modules ; list of strings @@ -199,6 +215,10 @@ (name-service-switch operating-system-name-service-switch ; (default %default-nss)) + (essential-services operating-system-essential-services ; list of services + (thunked) + (default (operating-system-default-essential-services + this-operating-system))) (services operating-system-user-services ; list of services (default %base-services)) @@ -233,6 +253,8 @@ directly by the user." ;; OS's root file system, so it might be a device path like "/dev/sda3". (root-device boot-parameters-root-device) (bootloader-name boot-parameters-bootloader-name) + (bootloader-menu-entries ;list of + boot-parameters-bootloader-menu-entries) (store-device boot-parameters-store-device) (store-mount-point boot-parameters-store-mount-point) (kernel boot-parameters-kernel) @@ -279,6 +301,11 @@ file system labels." ((_ args) args) (#f 'grub))) ; for compatibility reasons. + (bootloader-menu-entries + (match (assq 'bootloader-menu-entries rest) + ((_ entries) (map sexp->menu-entry entries)) + (#f '()))) + ;; In the past, we would store the directory name of the kernel instead ;; of the absolute file name of its image. Detect that and correct it. (kernel (if (string=? linux (direct-store-path linux)) @@ -421,42 +448,38 @@ from the initrd." "Return the list of swap services for OS." (map swap-service (operating-system-swap-devices os))) -(define* (system-linux-image-file-name #:optional (system (%current-system))) +(define* (system-linux-image-file-name) "Return the basename of the kernel image file for SYSTEM." ;; FIXME: Evaluate the conditional based on the actual current system. - (cond - ((string-prefix? "arm" (%current-system)) "zImage") - ((string-prefix? "mips" (%current-system)) "vmlinuz") - ((string-prefix? "aarch64" (%current-system)) "Image") - (else "bzImage"))) + (let ((target (or (%current-target-system) (%current-system)))) + (cond + ((string-prefix? "arm" target) "zImage") + ((string-prefix? "mips" target) "vmlinuz") + ((string-prefix? "aarch64" target) "Image") + (else "bzImage")))) (define (operating-system-kernel-file os) "Return an object representing the absolute file name of the kernel image of OS." (file-append (operating-system-kernel os) - "/" (system-linux-image-file-name os))) + "/" (system-linux-image-file-name))) -(define* (operating-system-directory-base-entries os #:key container?) +(define* (operating-system-directory-base-entries os) "Return the basic entries of the 'system' directory of OS for use as the value of the SYSTEM-SERVICE-TYPE service." (let ((locale (operating-system-locale-directory os))) - (with-monad %store-monad - (if container? - (return `(("locale" ,locale))) - (mlet %store-monad - ((kernel -> (operating-system-kernel os)) - (initrd -> (operating-system-initrd-file os)) - (params (operating-system-boot-parameters-file os))) - (return `(("kernel" ,kernel) - ("parameters" ,params) - ("initrd" ,initrd) - ("locale" ,locale)))))))) ;used by libc - -(define* (essential-services os #:key container?) + (mlet %store-monad ((kernel -> (operating-system-kernel os)) + (initrd -> (operating-system-initrd-file os)) + (params (operating-system-boot-parameters-file os))) + (return `(("kernel" ,kernel) + ("parameters" ,params) + ("initrd" ,initrd) + ("locale" ,locale)))))) ;used by libc + +(define (operating-system-default-essential-services os) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level -bookkeeping. CONTAINER? determines whether to return the list of services for -a container or that of a \"bare metal\" system." +bookkeeping." (define known-fs (map file-system-mount-point (operating-system-file-systems os))) @@ -466,8 +489,7 @@ a container or that of a \"bare metal\" system." (swaps (swap-services os)) (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?))) + (entries (operating-system-directory-base-entries os))) (cons* (service system-service-type entries) %boot-service @@ -484,7 +506,9 @@ a container or that of a \"bare metal\" system." (operating-system-groups os)) (operating-system-skeletons os)) (operating-system-etc-service os) - (service fstab-service-type '()) + (service fstab-service-type + (filter file-system-needed-for-boot? + (operating-system-file-systems os))) (session-environment-service (operating-system-environment-variables os)) host-name procs root-fs @@ -495,20 +519,36 @@ a container or that of a \"bare metal\" system." other-fs (append mappings swaps - ;; 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." + ;; Add the firmware service. + (list %linux-bare-metal-service + (service firmware-service-type + (operating-system-firmware os))))))) + +(define* (operating-system-services os) + "Return all the services of OS, including \"essential\" services." (instantiate-missing-services (append (operating-system-user-services os) - (essential-services os #:container? container?)))) + (operating-system-essential-services os)))) + +(define (operating-system-with-gc-roots os roots) + "Return a variant of OS where ROOTS are registered as GC roots." + (operating-system + (inherit os) + + ;; We use this procedure for the installation OS, which already defines GC + ;; roots. Add ROOTS to those. + (services (cons (simple-service 'extra-root + gc-root-service-type roots) + (operating-system-user-services os))))) + +(define* (operating-system-with-provenance os #:optional config-file) + "Return a variant of OS that stores its own provenance information, +including CONFIG-FILE, if available. This is achieved by adding an instance +of PROVENANCE-SERVICE-TYPE to its services." + (operating-system + (inherit os) + (services (cons (service provenance-service-type config-file) + (operating-system-user-services os))))) ;;; @@ -556,6 +596,7 @@ explicitly appear in OS." ;; variant propagated by 'guile-final' and the GMP variant propagated ;; by 'gnutls', itself propagated by 'guix'. guile-2.2 + guile-readline guile-colorized ;; The packages below are also in %FINAL-INPUTS, so take them from ;; there to avoid duplication. @@ -694,6 +735,10 @@ fi\n"))) ;; to certain networks. Some discussion at ;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html ("hostname" ,(plain-file "hostname" (operating-system-host-name os))) + ;; Some programs (e.g., GLib) look at /etc/timezone to find the + ;; name of the current timezone. For details, see + ;; https://lists.gnu.org/archive/html/guix-devel/2019-07/msg00166.html + ("timezone" ,(plain-file "timezone" (operating-system-timezone os))) ("localtime" ,(file-append tzdata "/share/zoneinfo/" (operating-system-timezone os))) ("sudoers" ,(operating-system-sudoers-file os)))))) @@ -795,7 +840,12 @@ use 'plain-file' instead~%") (file-append inetutils "/bin/ping6") (file-append sudo "/bin/sudo") (file-append sudo "/bin/sudoedit") - (file-append fuse "/bin/fusermount")))) + (file-append fuse "/bin/fusermount") + + ;; To allow mounts with the "user" option, "mount" and "umount" must + ;; be setuid-root. + (file-append util-linux "/bin/mount") + (file-append util-linux "/bin/umount")))) (define %sudoers-specification ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel' @@ -806,20 +856,19 @@ use 'plain-file' instead~%") root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n")) -(define* (operating-system-activation-script os #:key container?) +(define* (operating-system-activation-script os) "Return the activation script for OS---i.e., the code that \"activates\" the stateful part of OS, including user accounts and groups, special directories, etc." - (let* ((services (operating-system-services os #:container? container?)) + (let* ((services (operating-system-services os)) (activation (fold-services services #:target-type activation-service-type))) (activation-service->script activation))) -(define* (operating-system-boot-script os #:key container?) +(define* (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once -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?)) +we're running in the final root." + (let* ((services (operating-system-services os)) (boot (fold-services services #:target-type boot-service-type))) (service-value boot))) @@ -839,17 +888,17 @@ hardware-related operations as necessary when booting a Linux container." #:target-type shepherd-root-service-type)))) -(define* (operating-system-derivation os #:key container?) +(define* (operating-system-derivation os) "Return a derivation that builds OS." - (let* ((services (operating-system-services os #:container? container?)) + (let* ((services (operating-system-services os)) (system (fold-services services))) ;; SYSTEM contains the derivation as a monadic value. (service-value system))) -(define* (operating-system-profile os #:key container?) +(define* (operating-system-profile os) "Return a derivation that builds the system profile of OS." (mlet* %store-monad - ((services -> (operating-system-services os #:container? container?)) + ((services -> (operating-system-services os)) (profile (fold-services services #:target-type profile-service-type))) (match profile @@ -878,7 +927,8 @@ hardware-related operations as necessary when booting a Linux container." #:linux (operating-system-kernel os) #:linux-modules (operating-system-initrd-modules os) - #:mapped-devices mapped-devices)) + #:mapped-devices mapped-devices + #:keyboard-layout (operating-system-keyboard-layout os))) (define (locale-name->definition* name) "Variant of 'locale-name->definition' that raises an error upon failure." @@ -912,15 +962,18 @@ listed in OS. The C library expects to find it under (cond ((package? kernel) (string-append "GNU with " (string-titlecase (package-name kernel)) " " - (package-version kernel) - " (beta)")) + (package-version kernel))) ((inferior-package? kernel) (string-append "GNU with " (string-titlecase (inferior-package-name kernel)) " " - (inferior-package-version kernel) - " (beta)")) + (inferior-package-version kernel))) (else "GNU"))) +(define (operating-system-default-label os) + "Return the default label for OS, as it will appear in the bootloader menu +entry." + (kernel->boot-label (operating-system-kernel os))) + (define (store-file-system file-systems) "Return the file system object among FILE-SYSTEMS that contains the store." (match (filter (lambda (fs) @@ -969,7 +1022,7 @@ such as '--root' and '--load' to ." (bootloader (bootloader-configuration-bootloader (operating-system-bootloader os))) (bootloader-name (bootloader-name bootloader)) - (label (kernel->boot-label (operating-system-kernel os)))) + (label (operating-system-label os))) (boot-parameters (label label) (root-device root-device) @@ -980,6 +1033,8 @@ such as '--root' and '--load' to ." (operating-system-user-kernel-arguments os))) (initrd initrd) (bootloader-name bootloader-name) + (bootloader-menu-entries + (bootloader-configuration-menu-entries (operating-system-bootloader os))) (store-device (ensure-not-/dev (file-system-device store))) (store-mount-point (file-system-mount-point store))))) @@ -1021,6 +1076,11 @@ being stored into the \"parameters\" file)." #$(boot-parameters-kernel-arguments params)) (initrd #$(boot-parameters-initrd params)) (bootloader-name #$(boot-parameters-bootloader-name params)) + (bootloader-menu-entries + #$(map menu-entry->sexp + (or (and=> (operating-system-bootloader os) + bootloader-configuration-menu-entries) + '()))) (store (device #$(device->sexp (boot-parameters-store-device params)))