;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
-;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2015
, 2016 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
#: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 (ice-9 match)
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-derivation
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
(default "en_US.utf8"))
(locale-definitions operating-system-locale-definitions ; list of <locale-definition>
(default %default-locale-definitions))
+ (locale-libcs operating-system-locale-libcs ; list of <packages>
+ (default %default-locale-libcs))
(name-service-switch operating-system-name-service-switch ; <name-service-switch>
(default %default-nss))
(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)
- ;; XXX: Fiddling with dmd service names is not nice.
- (append (map (lambda (fs)
- (symbol-append 'file-system-
- (string->symbol
- (file-system-mount-point fs))))
- (file-system-dependencies fs))
- (map (lambda (md)
- (symbol-append 'device-mapping-
- (string->symbol (mapped-device-target md))))
- (device-mappings fs))))
-
- (map file-system-service 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)
"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
(swaps (swap-services os))
(procs (user-processes-service
(map service-parameters other-fs)))
- (host-name (host-name-service (operating-system-host-name os))))
- (cons* %boot-service
-
- ;; %DMD-ROOT-SERVICE must come first so that the gexp that execs
- ;; dmd comes last in the boot script (XXX).
- %dmd-root-service %activation-service
+ (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 (service firmware-service-type
+ (list %linux-bare-metal-service
+ (service firmware-service-type
(operating-system-firmware os))))))))
(define* (operating-system-services os #:key container?)
;; 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
;; many people are familiar with, so keep it around.
iw wireless-tools
+ iproute
net-tools ; XXX: remove when Inetutils suffices
man-db
+ texinfo ;for the standalone Info reader
;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
;; want the other commands and the man pages (notably because
;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
;; already depends on it anyway.
- kmod eudev
+ kmod eudev-with-blkid
e2fsprogs kbd
(chdir #$output)
(symlink #$(emacs-site-file) "site-start.el"))))
-(define (user-shells os)
- "Return the list of all the shells used by the accounts of OS. These may be
-gexps or strings."
- (map user-account-shell (operating-system-accounts os)))
-
-(define (shells-file shells)
- "Return a file-like object that builds a shell list for use as /etc/shells
-based on SHELLS. /etc/shells is used by xterm, polkit, and other programs."
- (computed-file "shells"
- #~(begin
- (use-modules (srfi srfi-1))
-
- (define shells
- (delete-duplicates (list #$@shells)))
-
- (call-with-output-file #$output
- (lambda (port)
- (display "\
-/bin/sh
-/run/current-system/profile/bin/sh
-/run/current-system/profile/bin/bash\n" port)
- (for-each (lambda (shell)
- (display shell port)
- (newline port))
- shells))))))
-
(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"))
- (shells (shells-file (user-shells os)))
(emacs (emacs-site-directory))
(issue (plain-file "issue" (operating-system-issue os)))
(nsswitch (plain-file "nsswitch.conf"
;; Startup file for POSIX-compliant login shells, which set system-wide
;; environment variables.
(profile (mixed-text-file "profile" "\
-export LANG=\"" (operating-system-locale os) "\"
-export TZ=\"" (operating-system-timezone os) "\"
-export TZDIR=\"" tzdata "/share/zoneinfo\"
-
-# Tell 'modprobe' & co. where to look for modules.
-export LINUX_MODULE_DIRECTORY=/run/booted-system/kernel/lib/modules
-
-# 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\"
-
# Crucial variables that could be missing in the profiles' 'etc/profile'
# because they would require combining both profiles.
# FIXME: See <http://bugs.gnu.org/20255>.
export PATH=\"$HOME/.guix-profile/bin:$PATH\"
fi
-# 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
+# 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'.
+if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\
+ -a -z \"$LINUX_MODULE_DIRECTORY\" ]
+then
+ . /etc/environment
+ export `cat /etc/environment | cut -d= -f1`
+fi
-# Allow Aspell to find dictionaries installed in the user profile.
-export ASPELL_CONF=\"dict-dir $HOME/.guix-profile/lib/aspell\"
# Allow GStreamer-based applications to find plugins.
export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"
("login.defs" ,#~#$login.defs)
("issue" ,#~#$issue)
("nsswitch.conf" ,#~#$nsswitch)
- ("shells" ,#~#$shells)
("profile" ,#~#$profile)
("bashrc" ,#~#$bashrc)
("hosts" ,#~#$(or (operating-system-hosts-file os)
#$(operating-system-timezone os)))
("sudoers" ,(operating-system-sudoers-file os))))))
-(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)))))
-
(define %root-account
;; Default root account.
(user-account
(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")
+ ;; Prepend the directory of 'site-start.el' to the search path, so
+ ;; that it has higher precedence than the 'site-start.el' file our
+ ;; Emacs package provides.
+ ("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.
+ ("DBUS_FATAL_WARNINGS" . "0")))
+
(define %setuid-programs
;; Default set of setuid-root programs.
(let ((shadow (@ (gnu packages admin) shadow)))
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)))
+ (boot (fold-services services #:target-type boot-service-type)))
;; BOOT is the script as a monadic value.
(service-parameters boot)))
+(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."
(find (match-lambda
#: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."
(package-version kernel)
" (alpha)"))
+(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
\"old entries\" menu."
(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
- (cons* (string-append "--root="
- (file-system-device root-fs))
+ (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)
#$(operating-system-kernel-arguments os))
(initrd #$initrd)))))
-(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)))
- (lower-object
- (file-union "system"
- `(("boot" ,#~#$boot)
- ("kernel" ,#~#$kernel)
- ("parameters" ,#~#$params)
- ("initrd" ,initrd)
- ("profile" ,#~#$profile)
- ("locale" ,#~#$locale) ;used by libc
- ("etc" ,#~#$etc))))))
+\f
+;;;
+;;; Boot parameters
+;;;
+
+(define-record-type* <boot-parameters>
+ 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
+<boot-parameters> 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
HCoop / jackhill / guix / guix.git / blobdiff