X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/cd9bc11273d11765db2c7431191c08d7ac969c7a..2b4185792d3ec9b43a5c1bb204b6846e5ac0f14a:/gnu/system.scm diff --git a/gnu/system.scm b/gnu/system.scm index c43a8ede5c..a49b3f29b3 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2015 Mark H Weaver +;;; Copyright © 2015, 2016 Alex Kost ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +26,7 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix profiles) + #:use-module (guix ui) #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages guile) @@ -37,19 +40,20 @@ #:use-module (gnu packages lsof) #:use-module (gnu packages gawk) #:use-module (gnu packages man) + #:use-module (gnu packages texinfo) #:use-module (gnu packages compression) #:use-module (gnu packages firmware) - #:autoload (gnu packages cryptsetup) (cryptsetup) #:use-module (gnu services) - #:use-module (gnu services dmd) + #:use-module (gnu services shepherd) #:use-module (gnu services base) #:use-module (gnu system grub) #:use-module (gnu system shadow) #:use-module (gnu system nss) #:use-module (gnu system locale) - #:use-module (gnu system linux) + #:use-module (gnu system pam) #:use-module (gnu system linux-initrd) #:use-module (gnu system file-systems) + #:use-module (gnu system mapped-devices) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -65,6 +69,7 @@ operating-system-host-name operating-system-hosts-file operating-system-kernel + operating-system-kernel-arguments operating-system-initrd operating-system-users operating-system-groups @@ -72,20 +77,33 @@ operating-system-timezone operating-system-locale operating-system-locale-definitions + operating-system-locale-libcs operating-system-mapped-devices operating-system-file-systems + operating-system-store-file-system operating-system-activation-script + operating-system-user-accounts + operating-system-shepherd-service-names operating-system-derivation operating-system-profile operating-system-grub.cfg + operating-system-etc-directory + operating-system-locale-directory + operating-system-boot-script + + boot-parameters + boot-parameters? + boot-parameters-label + boot-parameters-root-device + boot-parameters-kernel + boot-parameters-kernel-arguments + read-boot-parameters local-host-aliases %setuid-programs %base-packages - %base-firmware - - luks-device-mapping)) + %base-firmware)) ;;; Commentary: ;;; @@ -100,6 +118,8 @@ operating-system? (kernel operating-system-kernel ; package (default linux-libre)) + (kernel-arguments operating-system-kernel-arguments + (default '())) ; list of gexps/strings (bootloader operating-system-bootloader) ; (initrd operating-system-initrd ; (list fs) -> M derivation @@ -108,7 +128,7 @@ (default %base-firmware)) (host-name operating-system-host-name) ; string - (hosts-file operating-system-hosts-file ; M item | #f + (hosts-file operating-system-hosts-file ; file-like | #f (default #f)) (mapped-devices operating-system-mapped-devices ; list of @@ -118,7 +138,7 @@ (default '())) (users operating-system-users ; list of user accounts - (default '())) + (default %base-user-accounts)) (groups operating-system-groups ; list of user groups (default %base-groups)) @@ -135,6 +155,8 @@ (default "en_US.utf8")) (locale-definitions operating-system-locale-definitions ; list of (default %default-locale-definitions)) + (locale-libcs operating-system-locale-libcs ; list of + (default %default-locale-libcs)) (name-service-switch operating-system-name-service-switch ; (default %default-nss)) @@ -146,67 +168,14 @@ (setuid-programs operating-system-setuid-programs (default %setuid-programs)) ; list of string-valued gexps - (sudoers operating-system-sudoers ; /etc/sudoers contents - (default %sudoers-specification))) - - -;;; -;;; Derivation. -;;; - -(define* (file-union name files) - "Return a derivation that builds a directory containing all of FILES. Each -item in FILES must be a list where the first element is the file name to use -in the new directory, and the second element is a gexp denoting the target -file." - (define builder - #~(begin - (mkdir #$output) - (chdir #$output) - #$@(map (match-lambda - ((target source) - #~(symlink #$source #$target))) - files))) - - (gexp->derivation name builder)) - -(define (directory-union name things) - "Return a directory that is the union of THINGS." - (match things - ((one) - ;; Only one thing; return it. - (with-monad %store-monad (return one))) - (_ - (gexp->derivation name - #~(begin - (use-modules (guix build union)) - (union-build #$output '#$things)) - #:modules '((guix build union)) - #:local-build? #t)))) + (sudoers-file operating-system-sudoers-file ; file-like + (default %sudoers-specification))) ;;; ;;; Services. ;;; -(define (open-luks-device source target) - "Return a gexp that maps SOURCE to TARGET as a LUKS device, using -'cryptsetup'." - #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") - "open" "--type" "luks" - #$source #$target))) - -(define (close-luks-device source target) - "Return a gexp that closes TARGET, a LUKS device." - #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") - "close" #$target))) - -(define luks-device-mapping - ;; The type of LUKS mapped devices. - (mapped-device-kind - (open open-luks-device) - (close close-luks-device))) - (define (other-file-system-services os) "Return file system services for the file systems of OS that are not marked as 'needed-for-boot'." @@ -215,37 +184,32 @@ as 'needed-for-boot'." (operating-system-file-systems os))) (define (device-mappings fs) - (filter (lambda (md) - (string=? (string-append "/dev/mapper/" - (mapped-device-target md)) - (file-system-device fs))) - (operating-system-mapped-devices os))) - - (define (requirements fs) - (map (lambda (md) - (symbol-append 'device-mapping- - (string->symbol (mapped-device-target md)))) - (device-mappings fs))) - - (sequence %store-monad - (map (lambda (fs) - (match fs - (($ device title target type flags opts - #f check? create?) - (file-system-service device target type - #:title title - #:requirements (requirements fs) - #:check? check? - #:create-mount-point? create? - #:options opts - #:flags flags)))) - file-systems))) + (let ((device (file-system-device fs))) + (if (string? device) ;title is 'device + (filter (lambda (md) + (string=? (string-append "/dev/mapper/" + (mapped-device-target md)) + device)) + (operating-system-mapped-devices os)) + '()))) + + (define (add-dependencies fs) + ;; Add the dependencies due to device mappings to FS. + (file-system + (inherit fs) + (dependencies + (delete-duplicates (append (device-mappings fs) + (file-system-dependencies fs)) + eq?)))) + + (map (compose file-system-service add-dependencies) file-systems)) (define (mapped-device-user device file-systems) "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f." (let ((target (string-append "/dev/mapper/" (mapped-device-target device)))) (find (lambda (fs) - (string=? (file-system-device fs) target)) + (and (eq? 'device (file-system-title fs)) + (string=? (file-system-device fs) target))) file-systems))) (define (operating-system-user-mapped-devices os) @@ -270,51 +234,86 @@ from the initrd." devices))) (define (device-mapping-services os) - "Return the list of device-mapping services for OS as a monadic list." - (sequence %store-monad - (map (lambda (md) - (let* ((source (mapped-device-source md)) - (target (mapped-device-target md)) - (type (mapped-device-type md)) - (open (mapped-device-kind-open type)) - (close (mapped-device-kind-close type))) - (device-mapping-service target - (open source target) - (close source target)))) - (operating-system-user-mapped-devices os)))) + "Return the list of device-mapping services for OS as a list." + (map device-mapping-service + (operating-system-user-mapped-devices os))) (define (swap-services os) - "Return the list of swap services for OS as a monadic list." - (sequence %store-monad - (map swap-service (operating-system-swap-devices os)))) - -(define (essential-services os) + "Return the list of swap services for OS." + (map swap-service (operating-system-swap-devices os))) + +(define* (operating-system-directory-base-entries os #:key container?) + "Return the basic entries of the 'system' directory of OS for use as the +value of the SYSTEM-SERVICE-TYPE service." + (mlet %store-monad ((locale (operating-system-locale-directory os))) + (if container? + (return `(("locale" ,locale))) + (mlet %store-monad + ((kernel -> (operating-system-kernel os)) + (initrd (operating-system-initrd-file os)) + (params (operating-system-parameters-file os))) + (return `(("kernel" ,kernel) + ("parameters" ,params) + ("initrd" ,initrd) + ("locale" ,locale))))))) ;used by libc + +(define* (essential-services os #:key container?) "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." +bookkeeping. CONTAINER? determines whether to return the list of services for +a container or that of a \"bare metal\" system." (define known-fs (map file-system-mount-point (operating-system-file-systems os))) - (mlet* %store-monad ((mappings (device-mapping-services os)) - (root-fs (root-file-system-service)) - (other-fs (other-file-system-services os)) - (unmount (user-unmount-service known-fs)) - (swaps (swap-services os)) - (procs (user-processes-service - (map (compose first service-provision) - other-fs))) - (host-name (host-name-service - (operating-system-host-name os)))) - (return (cons* host-name procs root-fs unmount - (append other-fs mappings swaps))))) - -(define (operating-system-services os) + (let* ((mappings (device-mapping-services os)) + (root-fs (root-file-system-service)) + (other-fs (other-file-system-services os)) + (unmount (user-unmount-service known-fs)) + (swaps (swap-services os)) + (procs (user-processes-service + (map service-parameters other-fs))) + (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 + ;; execs shepherd comes last in the boot script (XXX). Likewise, + ;; the cleanup service must come last so that its gexp runs before + ;; activation code. + %shepherd-root-service + %activation-service + (service cleanup-service-type #f) + + (pam-root-service (operating-system-pam-services os)) + (account-service (append (operating-system-accounts os) + (operating-system-groups os)) + (operating-system-skeletons os)) + (operating-system-etc-service os) + (service fstab-service-type '()) + (session-environment-service + (operating-system-environment-variables os)) + host-name procs root-fs unmount + (service setuid-program-service-type + (operating-system-setuid-programs os)) + (service profile-service-type + (operating-system-packages os)) + (append other-fs mappings swaps + + ;; Add the firmware service, unless we are building for a + ;; container. + (if container? + '() + (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." - (mlet %store-monad - ((user (sequence %store-monad (operating-system-user-services os))) - (essential (essential-services os))) - (return (append essential user)))) + (append (operating-system-user-services os) + (essential-services os #:container? container?))) ;;; @@ -329,17 +328,18 @@ 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 - (@ (gnu packages admin) dmd) guix lsof ;for Guix's 'list-runtime-roots' pciutils usbutils util-linux inetutils isc-dhcp ;; 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 + iw wireless-tools rfkill + iproute net-tools ; XXX: remove when Inetutils suffices man-db + info-reader ;the standalone Info reader (no Perl) ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also ;; want the other commands and the man pages (notably because @@ -352,6 +352,8 @@ explicitly appear in OS." e2fsprogs kbd + bash-completion + ;; The packages below are also in %FINAL-INPUTS, so take them from ;; there to avoid duplication. (map canonical-package @@ -370,122 +372,99 @@ This is the GNU system. Welcome.\n") (define (default-/etc/hosts host-name) "Return the default /etc/hosts file." - (text-file "hosts" (local-host-aliases host-name))) - -(define (emacs-site-file) - "Return the Emacs 'site-start.el' file. That file contains the necessary -settings for 'guix.el' to work out-of-the-box." - (gexp->file "site-start.el" - #~(progn - ;; Add the "normal" elisp directory to the search path; - ;; guix.el may be there. - (add-to-list - 'load-path - "/run/current-system/profile/share/emacs/site-lisp") - - ;; Attempt to load guix.el. - (require 'guix-init nil t) - - (when (require 'geiser-guile nil t) - ;; Make sure Geiser's Scheme modules are in Guile's search - ;; path. - (add-to-list - 'geiser-guile-load-path - "/run/current-system/profile/share/geiser/guile"))))) - -(define (emacs-site-directory) - "Return the Emacs site directory, aka. /etc/emacs." - (mlet %store-monad ((file (emacs-site-file))) - (gexp->derivation "emacs" - #~(begin - (mkdir #$output) - (chdir #$output) - (symlink #$file "site-start.el"))))) - -(define* (etc-directory #:key - (locale "C") (timezone "Europe/Paris") - (issue "Hello!\n") - (skeletons '()) - (pam-services '()) - (profile "/run/current-system/profile") - hosts-file nss - (sudoers "")) - "Return a derivation that builds the static part of the /etc directory." - (mlet* %store-monad - ((pam.d (pam-services->directory pam-services)) - (sudoers (text-file "sudoers" sudoers)) - (login.defs (text-file "login.defs" "# Empty for now.\n")) - - ;; /etc/shells is used by xterm and other programs. We don't check - ;; whether these shells are installed, should be OK. - (shells (text-file "shells" - "\ -/bin/sh -/run/current-system/profile/bin/sh -/run/current-system/profile/bin/bash -/run/current-system/profile/bin/fish -/run/current-system/profile/bin/tcsh -/run/current-system/profile/bin/zsh\n")) - (emacs (emacs-site-directory)) - (issue (text-file "issue" issue)) - (nsswitch (text-file "nsswitch.conf" - (name-service-switch->string nss))) - - ;; Startup file for POSIX-compliant login shells, which set system-wide - ;; environment variables. - (profile (text-file* "profile" "\ -export LANG=\"" locale "\" -export TZ=\"" timezone "\" -export TZDIR=\"" tzdata "/share/zoneinfo\" - -# Tell 'modprobe' & co. where to look for modules. -export LINUX_MODULE_DIRECTORY=/run/booted-system/kernel/lib/modules - -export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin -export PATH=/run/setuid-programs:/run/current-system/profile/sbin:$PATH + (plain-file "hosts" (local-host-aliases host-name))) + +(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")) + + (issue (plain-file "issue" (operating-system-issue os))) + (nsswitch (plain-file "nsswitch.conf" + (name-service-switch->string + (operating-system-name-service-switch os)))) + + ;; Startup file for POSIX-compliant login shells, which set system-wide + ;; environment variables. + (profile (mixed-text-file "profile" "\ +# Crucial variables that could be missing in the profiles' 'etc/profile' +# because they would require combining both profiles. +# FIXME: See . export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info - 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 -# Append the directory of 'site-start.el' to the search path. -export EMACSLOADPATH=:/etc/emacs - -# By default, applications that use D-Bus, such as Emacs, abort at startup -# when /etc/machine-id is missing. Make sure these warnings are non-fatal. -export DBUS_FATAL_WARNINGS=0 - -# These variables are honored by OpenSSL (libssl) and Git. -export SSL_CERT_DIR=/etc/ssl/certs -export SSL_CERT_FILE=\"$SSL_CERT_DIR/ca-certificates.crt\" -export GIT_SSL_CAINFO=\"$SSL_CERT_FILE\" - -# Allow Aspell to find dictionaries installed in the user profile. -export ASPELL_CONF=\"dict-dir $HOME/.guix-profile/lib/aspell\" +# Ignore the default value of 'PATH'. +unset PATH + +# Load the system profile's settings. +GUIX_PROFILE=/run/current-system/profile \\ +. /run/current-system/profile/etc/profile + +# Prepend setuid programs. +export PATH=/run/setuid-programs:$PATH + +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 + +# 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'. +if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\ + -a -z \"$LINUX_MODULE_DIRECTORY\" ] +then + . /etc/environment + export `cat /etc/environment | cut -d= -f1` +fi + +# Set the umask, notably for users logging in via 'lsh'. +# See . +umask 022 + +# Allow GStreamer-based applications to find plugins. +export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\" + +if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ] +then + # Load Bash-specific initialization code. + . /etc/bashrc +fi ")) - (skel (skeleton-directory skeletons))) - (file-union "etc" - `(("services" ,#~(string-append #$net-base "/etc/services")) - ("protocols" ,#~(string-append #$net-base "/etc/protocols")) - ("rpc" ,#~(string-append #$net-base "/etc/rpc")) - ("emacs" ,#~#$emacs) - ("pam.d" ,#~#$pam.d) - ("login.defs" ,#~#$login.defs) - ("issue" ,#~#$issue) - ("nsswitch.conf" ,#~#$nsswitch) - ("skel" ,#~#$skel) - ("shells" ,#~#$shells) - ("profile" ,#~#$profile) - ("hosts" ,#~#$hosts-file) - ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" - #$timezone)) - ("sudoers" ,#~#$sudoers))))) - -(define (operating-system-profile os) - "Return a derivation that builds the system profile of OS." - (profile-derivation (manifest (map package->manifest-entry - (operating-system-packages os))))) + + (bashrc (plain-file "bashrc" "\ +# Bash-specific initialization. + +# The 'bash-completion' package. +if [ -f /run/current-system/profile/etc/profile.d/bash_completion.sh ] +then + # Bash-completion sources ~/.bash_completion. It installs a dynamic + # completion loader that searches its own completion files as well + # as those in ~/.guix-profile and /run/current-system/profile. + source /run/current-system/profile/etc/profile.d/bash_completion.sh +fi\n"))) + (etc-service + `(("services" ,#~(string-append #$net-base "/etc/services")) + ("protocols" ,#~(string-append #$net-base "/etc/protocols")) + ("rpc" ,#~(string-append #$net-base "/etc/rpc")) + ("login.defs" ,#~#$login.defs) + ("issue" ,#~#$issue) + ("nsswitch.conf" ,#~#$nsswitch) + ("profile" ,#~#$profile) + ("bashrc" ,#~#$bashrc) + ("hosts" ,#~#$(or (operating-system-hosts-file os) + (default-/etc/hosts (operating-system-host-name os)))) + ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" + #$(operating-system-timezone os))) + ("sudoers" ,(operating-system-sudoers-file os)))))) (define %root-account ;; Default root account. @@ -497,40 +476,72 @@ export ASPELL_CONF=\"dict-dir $HOME/.guix-profile/lib/aspell\" (home-directory "/root"))) (define (operating-system-accounts os) - "Return the user accounts for OS, including an obligatory 'root' account." - (define users - ;; Make sure there's a root account. - (if (find (lambda (user) - (and=> (user-account-uid user) zero?)) - (operating-system-users os)) - (operating-system-users os) - (cons %root-account (operating-system-users os)))) - - (mlet %store-monad ((services (operating-system-services os))) - (return (append users - (append-map service-user-accounts services))))) + "Return the user accounts for OS, including an obligatory 'root' account, +and excluding accounts requested by services." + ;; Make sure there's a root account. + (if (find (lambda (user) + (and=> (user-account-uid user) zero?)) + (operating-system-users os)) + (operating-system-users os) + (cons %root-account (operating-system-users os)))) + +(define (maybe-string->file file-name thing) + "If THING is a string, return a with THING as its content. +Otherwise just return THING. + +This is for backward-compatibility of fields that used to be strings and are +now file-like objects.." + (match thing + ((? string?) + (warning (_ "using a string for file '~a' is deprecated; \ +use 'plain-file' instead~%") + file-name) + (plain-file file-name thing)) + (x + x))) + +(define (maybe-file->monadic file-name thing) + "If THING is a value in %STORE-MONAD, return it as is; otherwise return +THING in the %STORE-MONAD. + +This is for backward-compatibility of fields that used to be monadic values +and are now file-like objects." + (with-monad %store-monad + (match thing + ((? procedure?) + (warning (_ "using a monadic value for '~a' is deprecated; \ +use 'plain-file' instead~%") + file-name) + thing) + (x + (return x))))) (define (operating-system-etc-directory os) "Return that static part of the /etc directory of OS." - (mlet* %store-monad - ((services (operating-system-services os)) - (pam-services -> - ;; Services known to PAM. - (append (operating-system-pam-services os) - (append-map service-pam-services services))) - (profile-drv (operating-system-profile os)) - (skeletons (operating-system-skeletons os)) - (/etc/hosts (or (operating-system-hosts-file os) - (default-/etc/hosts (operating-system-host-name os))))) - (etc-directory #:pam-services pam-services - #:skeletons skeletons - #:issue (operating-system-issue os) - #:locale (operating-system-locale os) - #:nss (operating-system-name-service-switch os) - #:timezone (operating-system-timezone os) - #:hosts-file /etc/hosts - #:sudoers (operating-system-sudoers os) - #:profile profile-drv))) + (etc-directory + (fold-services (operating-system-services os) + #:target-type etc-service-type))) + +(define (operating-system-environment-variables os) + "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)) + ("TZDIR" . ,#~(string-append #$tzdata "/share/zoneinfo")) + ;; Tell 'modprobe' & co. where to look for modules. + ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules") + ;; These variables are honored by OpenSSL (libssl) and Git. + ("SSL_CERT_DIR" . "/etc/ssl/certs") + ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt") + ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt") + + ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are + ;; searched for. + ("GTK_DATA_PREFIX" . "/run/current-system/profile") + + ;; By default, applications that use D-Bus, such as Emacs, abort at startup + ;; when /etc/machine-id is missing. Make sure these warnings are non-fatal. + ("DBUS_FATAL_WARNINGS" . "0"))) (define %setuid-programs ;; Default set of setuid-root programs. @@ -538,6 +549,7 @@ export ASPELL_CONF=\"dict-dir $HOME/.guix-profile/lib/aspell\" (list #~(string-append #$shadow "/bin/passwd") #~(string-append #$shadow "/bin/su") #~(string-append #$inetutils "/bin/ping") + #~(string-append #$inetutils "/bin/ping6") #~(string-append #$sudo "/bin/sudo") #~(string-append #$fuse "/bin/fusermount")))) @@ -546,155 +558,60 @@ export ASPELL_CONF=\"dict-dir $HOME/.guix-profile/lib/aspell\" ;; group can do anything. See ;; . ;; TODO: Add a declarative API. - "root ALL=(ALL) ALL -%wheel ALL=(ALL) ALL\n") - -(define (user-group->gexp group) - "Turn GROUP, a object, into a list-valued gexp suitable for -'active-groups'." - #~(list #$(user-group-name group) - #$(user-group-password group) - #$(user-group-id group) - #$(user-group-system? group))) - -(define (user-account->gexp account) - "Turn ACCOUNT, a object, into a list-valued gexp suitable for -'activate-users'." - #~`(#$(user-account-name account) - #$(user-account-uid account) - #$(user-account-group account) - #$(user-account-supplementary-groups account) - #$(user-account-comment account) - #$(user-account-home-directory account) - ,#$(user-account-shell account) ; this one is a gexp - #$(user-account-password account) - #$(user-account-system? account))) - -(define (modprobe-wrapper) - "Return a wrapper for the 'modprobe' command that knows where modules live. - -This wrapper is typically invoked by the Linux kernel ('call_modprobe', in -kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment -variable is not set---hence the need for this wrapper." - (let ((modprobe "/run/current-system/profile/bin/modprobe")) - (gexp->script "modprobe" - #~(begin - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - (apply execl #$modprobe - (cons #$modprobe (cdr (command-line)))))))) - -(define (operating-system-activation-script os) + (plain-file "sudoers" "\ +root ALL=(ALL) ALL +%wheel ALL=(ALL) ALL\n")) + +(define* (operating-system-activation-script os #:key container?) "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." - (define %modules - '((gnu build activation) - (gnu build linux-boot) - (gnu build linux-modules) - (gnu build file-systems) - (guix build utils) - (guix elf))) - - (define (service-activations services) - ;; Return the activation scripts for SERVICES. - (let ((gexps (filter-map service-activate services))) - (sequence %store-monad (map (cut gexp->file "activate-service.scm" <>) - gexps)))) - - (mlet* %store-monad ((services (operating-system-services os)) - (actions (service-activations services)) - (etc (operating-system-etc-directory os)) - (modules (imported-modules %modules)) - (compiled (compiled-modules %modules)) - (modprobe (modprobe-wrapper)) - (firmware (directory-union - "firmware" (operating-system-firmware os))) - (accounts (operating-system-accounts os))) - (define setuid-progs - (operating-system-setuid-programs os)) - - (define user-specs - (map user-account->gexp accounts)) - - (define groups - (append (operating-system-groups os) - (append-map service-user-groups services))) - - (define group-specs - (map user-group->gexp groups)) - - (gexp->file "activate" - #~(begin - (eval-when (expand load eval) - ;; Make sure 'use-modules' below succeeds. - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - - (use-modules (gnu build activation)) - - ;; Make sure /bin/sh is valid and current. - (activate-/bin/sh - (string-append #$(canonical-package bash) - "/bin/sh")) - - ;; Populate /etc. - (activate-etc #$etc) - - ;; Add users and user groups. - (setenv "PATH" - (string-append #$(@ (gnu packages admin) shadow) - "/sbin")) - (activate-users+groups (list #$@user-specs) - (list #$@group-specs)) - - ;; Activate setuid programs. - (activate-setuid-programs (list #$@setuid-progs)) - - ;; Tell the kernel to use our 'modprobe' command. - (activate-modprobe #$modprobe) - - ;; Tell the kernel where firmware is. - (activate-firmware - (string-append #$firmware "/lib/firmware")) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions) - - ;; Set up /run/current-system. - (activate-current-system))))) - -(define (operating-system-boot-script os) + (let* ((services (operating-system-services os #:container? container?)) + (activation (fold-services services + #:target-type activation-service-type))) + (activation-service->script activation))) + +(define* (operating-system-boot-script os #:key container?) "Return the boot script for OS---i.e., the code started by the initrd once -we're running in the final root." - (mlet* %store-monad ((services (operating-system-services os)) - (activate (operating-system-activation-script os)) - (dmd-conf (dmd-configuration-file services))) - (gexp->file "boot" - #~(begin - ;; Activate the system. - ;; TODO: Use 'load-compiled'. - (primitive-load #$activate) - - ;; Keep track of the booted system. - (false-if-exception (delete-file "/run/booted-system")) - (symlink (readlink "/run/current-system") - "/run/booted-system") - - ;; Close any remaining open file descriptors to be on the - ;; safe side. This must be the very last thing we do, - ;; because Guile has internal FDs such as 'sleep_pipe' - ;; that need to be alive. - (let loop ((fd 3)) - (when (< fd 1024) - (false-if-exception (close-fdes fd)) - (loop (+ 1 fd)))) - - ;; Start dmd. - (execl (string-append #$dmd "/bin/dmd") - "dmd" "--config" #$dmd-conf))))) +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-parameters boot))) + +(define (operating-system-user-accounts os) + "Return the list of user accounts of OS." + (let* ((services (operating-system-services os)) + (account (fold-services services + #:target-type account-service-type))) + (filter user-account? + (service-parameters account)))) + +(define (operating-system-shepherd-service-names os) + "Return the list of Shepherd service names for OS." + (append-map shepherd-service-provision + (service-parameters + (fold-services (operating-system-services os) + #:target-type + shepherd-root-service-type)))) + +(define* (operating-system-derivation os #:key container?) + "Return a derivation that builds OS." + (let* ((services (operating-system-services os #:container? container?)) + (system (fold-services services))) + ;; SYSTEM contains the derivation as a monadic value. + (service-parameters system))) + +(define* (operating-system-profile os #:key container?) + "Return a derivation that builds the system profile of OS." + (mlet* %store-monad + ((services -> (operating-system-services os #:container? container?)) + (profile (fold-services services + #:target-type profile-service-type))) + (match profile + (("profile" profile) + (return profile))))) (define (operating-system-root-file-system os) "Return the root file system of OS." @@ -716,28 +633,64 @@ we're running in the final root." (operating-system-initrd os)) (mlet %store-monad ((initrd (make-initrd boot-file-systems + #:linux (operating-system-kernel os) #:mapped-devices mapped-devices))) (return #~(string-append #$initrd "/initrd")))) +(define (locale-name->definition* name) + "Variant of 'locale-name->definition' that raises an error upon failure." + (match (locale-name->definition name) + (#f + (raise (condition + (&message + (message (format #f (_ "~a: invalid locale name") name)))))) + (def def))) + (define (operating-system-locale-directory os) "Return the directory containing the locales compiled for the definitions listed in OS. The C library expects to find it under /run/current-system/locale." - ;; While we're at it, check whether the locale of OS is defined. - (unless (member (operating-system-locale os) - (map locale-definition-name - (operating-system-locale-definitions os))) - (raise (condition - (&message (message "system locale lacks a definition"))))) + (define name + (operating-system-locale os)) + + (define definitions + ;; While we're at it, check whether NAME is defined and add it if needed. + (if (member name (map locale-definition-name + (operating-system-locale-definitions os))) + (operating-system-locale-definitions os) + (cons (locale-name->definition* name) + (operating-system-locale-definitions os)))) - (locale-directory (operating-system-locale-definitions os))) + (locale-directory definitions + #:libcs (operating-system-locale-libcs os))) (define (kernel->grub-label kernel) "Return a label for the GRUB menu entry that boots KERNEL." (string-append "GNU with " (string-titlecase (package-name kernel)) " " (package-version kernel) - " (alpha)")) + " (beta)")) + +(define (store-file-system file-systems) + "Return the file system object among FILE-SYSTEMS that contains the store." + (match (filter (lambda (fs) + (and (file-system-mount? fs) + (not (memq 'bind-mount (file-system-flags fs))) + (string-prefix? (file-system-mount-point fs) + (%store-prefix)))) + file-systems) + ((and candidates (head . tail)) + (reduce (lambda (fs1 fs2) + (if (> (string-length (file-system-mount-point fs1)) + (string-length (file-system-mount-point fs2))) + fs1 + fs2)) + head + candidates)))) + +(define (operating-system-store-file-system os) + "Return the file system that contains the store of OS." + (store-file-system (operating-system-file-systems os))) (define* (operating-system-grub.cfg os #:optional (old-entries '())) "Return the GRUB configuration file for OS. Use OLD-ENTRIES to populate the @@ -745,18 +698,23 @@ listed in OS. The C library expects to find it under (mlet* %store-monad ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) + (store-fs -> (operating-system-store-file-system os)) (kernel -> (operating-system-kernel os)) + (root-device -> (if (eq? 'uuid (file-system-title root-fs)) + (uuid->string (file-system-device root-fs)) + (file-system-device root-fs))) (entries -> (list (menu-entry (label (kernel->grub-label kernel)) (linux kernel) (linux-arguments - (list (string-append "--root=" - (file-system-device root-fs)) - #~(string-append "--system=" #$system) - #~(string-append "--load=" #$system - "/boot"))) + (cons* (string-append "--root=" root-device) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system + "/boot") + (operating-system-kernel-arguments os))) (initrd #~(string-append #$system "/initrd")))))) - (grub-configuration-file (operating-system-bootloader os) entries + (grub-configuration-file (operating-system-bootloader os) + store-fs entries #:old-entries old-entries))) (define (operating-system-parameters-file os) @@ -771,25 +729,42 @@ this file is the reconstruction of GRUB menu entries for old configurations." (label #$label) (root-device #$(file-system-device root)) (kernel #$(operating-system-kernel os)) - (initrd #$initrd))))) + (kernel-arguments + #$(operating-system-kernel-arguments os)) + (initrd #$initrd)) + #:set-load-path? #f))) -(define (operating-system-derivation os) - "Return a derivation that builds OS." - (mlet* %store-monad - ((profile (operating-system-profile os)) - (etc (operating-system-etc-directory os)) - (boot (operating-system-boot-script os)) - (kernel -> (operating-system-kernel os)) - (initrd (operating-system-initrd-file os)) - (locale (operating-system-locale-directory os)) - (params (operating-system-parameters-file os))) - (file-union "system" - `(("boot" ,#~#$boot) - ("kernel" ,#~#$kernel) - ("parameters" ,#~#$params) - ("initrd" ,initrd) - ("profile" ,#~#$profile) - ("locale" ,#~#$locale) ;used by libc - ("etc" ,#~#$etc))))) + +;;; +;;; Boot parameters +;;; + +(define-record-type* + boot-parameters make-boot-parameters boot-parameters? + (label boot-parameters-label) + (root-device boot-parameters-root-device) + (kernel boot-parameters-kernel) + (kernel-arguments boot-parameters-kernel-arguments)) + +(define (read-boot-parameters port) + "Read boot parameters from PORT and return the corresponding + object or #f if the format is unrecognized." + (match (read port) + (('boot-parameters ('version 0) + ('label label) ('root-device root) + ('kernel linux) + rest ...) + (boot-parameters + (label label) + (root-device root) + (kernel linux) + (kernel-arguments + (match (assq 'kernel-arguments rest) + ((_ args) args) + (#f '()))))) ;the old format + (x ;unsupported format + (warning (_ "unrecognized boot parameters for '~a'~%") + system) + #f))) ;;; system.scm ends here