;;; GNU Guix --- Functional package management for GNU
;;; 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 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)
operating-system-locale-libcs
operating-system-mapped-devices
operating-system-file-systems
+ operating-system-store-file-system
+ operating-system-user-mapped-devices
+ operating-system-boot-mapped-devices
operating-system-activation-script
+ operating-system-user-accounts
+ operating-system-shepherd-service-names
operating-system-derivation
operating-system-profile
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:
;;;
;;; 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'."
"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)
- (and (eq? 'device (file-system-title fs))
- (string=? (file-system-device fs) target)))
+ (or (member device (file-system-dependencies fs))
+ (and (eq? 'device (file-system-title fs))
+ (string=? (file-system-device fs) target))))
file-systems)))
(define (operating-system-user-mapped-devices os)
(define (device-mapping-services os)
"Return the list of device-mapping services for OS as a list."
- (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))))
+ (map device-mapping-service
(operating-system-user-mapped-devices os)))
(define (swap-services os)
(cons* (service system-service-type entries)
%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
+ ;; %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)
;; 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
"Return the default /etc/hosts file."
(plain-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."
- (scheme-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)
-
- ;; Attempt to load geiser.
- (require 'geiser-install nil t))))
-
-(define (emacs-site-directory)
- "Return the Emacs site directory, aka. /etc/emacs."
- (computed-file "emacs"
- #~(begin
- (mkdir #$output)
- (chdir #$output)
- (symlink #$(emacs-site-file) "site-start.el"))))
-
(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"))
- (emacs (emacs-site-directory))
(issue (plain-file "issue" (operating-system-issue os)))
(nsswitch (plain-file "nsswitch.conf"
(name-service-switch->string
export PATH=\"$HOME/.guix-profile/bin:$PATH\"
fi
-# Allow Aspell to find dictionaries installed in the user profile.
-export ASPELL_CONF=\"dict-dir $HOME/.guix-profile/lib/aspell\"
+# 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
+
+# Set the umask, notably for users logging in via 'lsh'.
+# See <http://bugs.gnu.org/22650>.
+umask 022
# Allow GStreamer-based applications to find plugins.
export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"
`(("services" ,#~(string-append #$net-base "/etc/services"))
("protocols" ,#~(string-append #$net-base "/etc/protocols"))
("rpc" ,#~(string-append #$net-base "/etc/rpc"))
- ("emacs" ,#~#$emacs)
("login.defs" ,#~#$login.defs)
("issue" ,#~#$issue)
("nsswitch.conf" ,#~#$nsswitch)
("SSL_CERT_DIR" . "/etc/ssl/certs")
("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")
- ;; Append the directory of 'site-start.el' to the search path.
- ("EMACSLOADPATH" . ":/etc/emacs")
+
+ ;; '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")))
;; 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?))
#: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")))))
-
- (locale-directory (operating-system-locale-definitions os)
+ (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 definitions
#:libcs (operating-system-locale-libcs os)))
(define (kernel->grub-label 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
(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))
"/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)
(kernel #$(operating-system-kernel os))
(kernel-arguments
#$(operating-system-kernel-arguments os))
- (initrd #$initrd)))))
+ (initrd #$initrd))
+ #:set-load-path? #f)))
+
+\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