diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/install.scm | 155 | ||||
| -rw-r--r-- | gnu/system/linux.scm | 49 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 156 |
3 files changed, 232 insertions, 128 deletions
diff --git a/gnu/system/install.scm b/gnu/system/install.scm index c161526d77..a91c5c3533 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -24,6 +24,7 @@ #:use-module (guix monads) #:use-module ((guix store) #:select (%store-prefix)) #:use-module (guix profiles) + #:use-module (gnu services dmd) #:use-module (gnu packages admin) #:use-module (gnu packages bash) #:use-module (gnu packages linux) @@ -102,7 +103,7 @@ under /root/.guix-profile where GUIX is installed." (define (log-to-info) "Return a script that spawns the Info reader on the right section of the manual." - (gexp->script "log-to-info" + (program-file "log-to-info" #~(begin ;; 'gunzip' is needed to decompress the doc. (setenv "PATH" (string-append #$gzip "/bin")) @@ -159,70 +160,74 @@ current store is on a RAM disk." (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE) (rmdir "/.rw-store")))))) +(define cow-store-service-type + (dmd-service-type + (lambda _ + (dmd-service + (requirement '(root-file-system user-processes)) + (provision '(cow-store)) + (documentation + "Make the store copy-on-write, with writes going to \ +the given target.") + + ;; This is meant to be explicitly started by the user. + (auto-start? #f) + + (start #~(case-lambda + ((target) + #$(make-cow-store #~target) + target) + (else + ;; Do nothing, and mark the service as stopped. + #f))) + (stop #~(lambda (target) + ;; Delete the temporary directory, but leave everything + ;; mounted as there may still be processes using it since + ;; 'user-processes' doesn't depend on us. The 'user-unmount' + ;; service will unmount TARGET eventually. + (delete-file-recursively + (string-append target #$%backing-directory)))))))) + (define (cow-store-service) "Return a service that makes the store copy-on-write, such that writes go to the user's target storage device rather than on the RAM disk." ;; See <http://bugs.gnu.org/18061> for the initial report. - (with-monad %store-monad - (return (service - (requirement '(root-file-system user-processes)) - (provision '(cow-store)) - (documentation - "Make the store copy-on-write, with writes going to \ -the given target.") + (service cow-store-service-type 'mooooh!)) + + +(define (/etc/configuration-files _) + "Return a list of tuples representing configuration templates to add to +/etc." + (define (file f) + (local-file (search-path %load-path + (string-append "gnu/system/examples/" f)))) + + (define directory + (computed-file "configuration-templates" + #~(begin + (mkdir #$output) + (for-each (lambda (file target) + (copy-file file + (string-append #$output "/" + target))) + '(#$(file "bare-bones.tmpl") + #$(file "desktop.tmpl")) + '("bare-bones.scm" + "desktop.scm")) + #t) + #:modules '((guix build utils)))) + + `(("configuration" ,directory))) + +(define configuration-template-service-type + (service-type (name 'configuration-template) + (extensions + (list (service-extension etc-service-type + /etc/configuration-files))))) + +(define %configuration-template-service + (service configuration-template-service-type #t)) - ;; This is meant to be explicitly started by the user. - (auto-start? #f) - - (start #~(case-lambda - ((target) - #$(make-cow-store #~target) - target) - (else - ;; Do nothing, and mark the service as stopped. - #f))) - (stop #~(lambda (target) - ;; Delete the temporary directory, but leave everything - ;; mounted as there may still be processes using it - ;; since 'user-processes' doesn't depend on us. The - ;; 'user-unmount' service will unmount TARGET - ;; eventually. - (delete-file-recursively - (string-append target #$%backing-directory)))))))) - -(define (configuration-template-service) - "Return a dummy service whose purpose is to install an operating system -configuration template file in the installation system." - - (define search - (cut search-path %load-path <>)) - (define templates - (map (match-lambda - ((file '-> target) - (list (local-file (search file)) - (string-append "/etc/configuration/" target)))) - '(("gnu/system/examples/bare-bones.tmpl" -> "bare-bones.scm") - ("gnu/system/examples/desktop.tmpl" -> "desktop.scm")))) - - (with-monad %store-monad - (return (service - (requirement '(root-file-system)) - (provision '(os-config-template)) - (documentation - "This dummy service installs an OS configuration template.") - (start #~(const #t)) - (stop #~(const #f)) - (activate - #~(begin - (use-modules (ice-9 match) - (guix build utils)) - - (mkdir-p "/etc/configuration") - (for-each (match-lambda - ((file target) - (unless (file-exists? target) - (copy-file file target)))) - '#$templates))))))) (define %nscd-minimal-caches ;; Minimal in-memory caching policy for nscd. @@ -234,7 +239,7 @@ configuration template file in the installation system." (define (installation-services) "Return the list services for the installation image." - (let ((motd (text-file "motd" " + (let ((motd (plain-file "motd" " Welcome to the installation of the Guix System Distribution! There is NO WARRANTY, to the extent permitted by law. In particular, you may @@ -244,25 +249,27 @@ it is alpha software, so it may BREAK IN UNEXPECTED WAYS. You have been warned. Thanks for being so brave. "))) (define (normal-tty tty) - (mingetty-service tty - #:motd motd - #:auto-login "root" - #:login-pause? #t)) + (mingetty-service (mingetty-configuration (tty tty) + (motd motd) + (auto-login "root") + (login-pause? #t)))) - (list (mingetty-service "tty1" - #:motd motd - #:auto-login "root") + (list (mingetty-service (mingetty-configuration + (tty "tty1") + (motd motd) + (auto-login "root"))) ;; Documentation. The manual is in UTF-8, but ;; 'console-font-service' sets up Unicode support and loads a font ;; with all the useful glyphs like em dash and quotation marks. - (mingetty-service "tty2" - #:motd motd - #:auto-login "guest" - #:login-program (log-to-info)) + (mingetty-service (mingetty-configuration + (tty "tty2") + (motd motd) + (auto-login "guest") + (login-program (log-to-info)))) ;; Documentation add-on. - (configuration-template-service) + %configuration-template-service ;; A bunch of 'root' ttys. (normal-tty "tty3") @@ -276,7 +283,7 @@ You have been warned. Thanks for being so brave. ;; The build daemon. Register the hydra.gnu.org key as trusted. ;; This allows the installation process to use substitutes by ;; default. - (guix-service #:authorize-hydra-key? #t) + (guix-service (guix-configuration (authorize-key? #t))) ;; Start udev so that useful device nodes are available. ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 7461a4a61f..cd14bc97be 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,11 +17,10 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu system linux) - #:use-module (guix store) #:use-module (guix records) #:use-module (guix derivations) - #:use-module (guix monads) #:use-module (guix gexp) + #:use-module (gnu services) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -30,7 +29,10 @@ pam-entry pam-services->directory unix-pam-service - base-pam-services)) + base-pam-services + + pam-root-service-type + pam-root-service)) ;;; Commentary: ;;; @@ -86,18 +88,13 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." (map (cut entry->gexp "session" <>) session)) #t)))) - (gexp->derivation name builder)))) + (computed-file name builder)))) (define (pam-services->directory services) "Return the derivation to build the configuration directory to be used as /etc/pam.d for SERVICES." - (mlet %store-monad - ((names -> (map pam-service-name services)) - (files (sequence %store-monad - (map pam-service->configuration - ;; XXX: Eventually, SERVICES may be a list of - ;; monadic values instead of plain values. - services)))) + (let ((names (map pam-service-name services)) + (files (map pam-service->configuration services))) (define builder #~(begin (use-modules (ice-9 match) @@ -105,8 +102,8 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." (mkdir #$output) (for-each (match-lambda - ((name file) - (symlink file (string-append #$output "/" name)))) + ((name file) + (symlink file (string-append #$output "/" name)))) ;; Since <pam-service> objects cannot be compared with ;; 'equal?' since they contain gexps, which contain @@ -114,7 +111,7 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." ;; instead. See <http://bugs.gnu.org/20037>. (delete-duplicates '#$(zip names files))))) - (gexp->derivation "pam.d" builder))) + (computed-file "pam.d" builder))) (define %pam-other-services ;; The "other" PAM configuration, which denies everything (see @@ -136,7 +133,7 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." (lambda* (name #:key allow-empty-passwords? motd) "Return a standard Unix-style PAM service for NAME. When ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords. When MOTD is true, it -should be the name of a file used as the message-of-the-day." +should be a file-like object used as the message-of-the-day." ;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>. (let ((name* name)) (pam-service @@ -195,4 +192,24 @@ authenticate to run COMMAND." '("useradd" "userdel" "usermod" "groupadd" "groupdel" "groupmod")))) + +;;; +;;; PAM root service. +;;; + +(define (/etc-entry services) + `(("pam.d" ,(pam-services->directory services)))) + +(define pam-root-service-type + (service-type (name 'pam) + (extensions (list (service-extension etc-service-type + /etc-entry))) + (compose concatenate) + (extend append))) + +(define (pam-root-service base) + "The \"root\" PAM service, which collects <pam-service> instance and turns +them into a /etc/pam.d directory, including the <pam-service> listed in BASE." + (service pam-root-service-type base)) + ;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index f033109614..3f49c1fc9f 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -20,15 +20,16 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:use-module (guix sets) #:use-module (guix ui) + #:use-module (gnu services) #:use-module ((gnu system file-systems) #:select (%tty-gid)) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) #:use-module (gnu packages guile-wm) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -55,7 +56,9 @@ skeleton-directory %base-groups %base-user-accounts - assert-valid-users/groups)) + + account-service-type + account-service)) ;;; Commentary: ;;; @@ -88,31 +91,32 @@ (system? user-group-system? ; Boolean (default #f))) + (define %base-groups ;; Default set of groups. (let-syntax ((system-group (syntax-rules () ((_ args ...) (user-group (system? #t) args ...))))) (list (system-group (name "root") (id 0)) - (system-group (name "wheel")) ; root-like users - (system-group (name "users")) ; normal users - (system-group (name "nogroup")) ; for daemons etc. + (system-group (name "wheel")) ; root-like users + (system-group (name "users")) ; normal users + (system-group (name "nogroup")) ; for daemons etc. ;; The following groups are conventionally used by things like udev to ;; control access to hardware devices. (system-group (name "tty") (id %tty-gid)) (system-group (name "dialout")) (system-group (name "kmem")) - (system-group (name "input")) ; input devices, from udev + (system-group (name "input")) ; input devices, from udev (system-group (name "video")) (system-group (name "audio")) - (system-group (name "netdev")) ; used in avahi-dbus.conf + (system-group (name "netdev")) ; used in avahi-dbus.conf (system-group (name "lp")) (system-group (name "disk")) (system-group (name "floppy")) (system-group (name "cdrom")) (system-group (name "tape")) - (system-group (name "kvm"))))) ; for /dev/kvm + (system-group (name "kvm"))))) ; for /dev/kvm (define %base-user-accounts ;; List of standard user accounts. Note that "root" is a special case, so @@ -133,10 +137,10 @@ (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) #$output))) - (mlet %store-monad ((profile (text-file "bash_profile" "\ + (let ((profile (plain-file "bash_profile" "\ # Honor per-interactive-shell startup file if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n")) - (bashrc (text-file "bashrc" "\ + (bashrc (plain-file "bashrc" "\ # Bash initialization for interactive non-login shells and # for remote shells (info \"(bash) Bash Startup Files\"). @@ -162,42 +166,41 @@ else fi alias ls='ls -p --color' alias ll='ls -l'\n")) - (zlogin (text-file "zlogin" "\ + (zlogin (plain-file "zlogin" "\ # Honor system-wide environment variables source /etc/profile\n")) - (guile-wm (gexp->derivation "guile-wm" copy-guile-wm - #:modules - '((guix build utils)))) - (xdefaults (text-file "Xdefaults" "\ + (guile-wm (computed-file "guile-wm" copy-guile-wm + #:modules '((guix build utils)))) + (xdefaults (plain-file "Xdefaults" "\ XTerm*utf8: always XTerm*metaSendsEscape: true\n")) - (gdbinit (text-file "gdbinit" "\ + (gdbinit (plain-file "gdbinit" "\ # Tell GDB where to look for separate debugging files. set debug-file-directory ~/.guix-profile/lib/debug\n"))) - (return `((".bash_profile" ,profile) - (".bashrc" ,bashrc) - (".zlogin" ,zlogin) - (".Xdefaults" ,xdefaults) - (".guile-wm" ,guile-wm) - (".gdbinit" ,gdbinit))))) + `((".bash_profile" ,profile) + (".bashrc" ,bashrc) + (".zlogin" ,zlogin) + (".Xdefaults" ,xdefaults) + (".guile-wm" ,guile-wm) + (".gdbinit" ,gdbinit)))) (define (skeleton-directory skeletons) - "Return a directory containing SKELETONS, a list of name/derivation pairs." - (gexp->derivation "skel" - #~(begin - (use-modules (ice-9 match)) - - (mkdir #$output) - (chdir #$output) - - ;; Note: copy the skeletons instead of symlinking - ;; them like 'file-union' does, because 'useradd' - ;; would just copy the symlinks as is. - (for-each (match-lambda - ((target source) - (copy-file source target))) - '#$skeletons) - #t))) + "Return a directory containing SKELETONS, a list of name/derivation tuples." + (computed-file "skel" + #~(begin + (use-modules (ice-9 match)) + + (mkdir #$output) + (chdir #$output) + + ;; Note: copy the skeletons instead of symlinking + ;; them like 'file-union' does, because 'useradd' + ;; would just copy the symlinks as is. + (for-each (match-lambda + ((target source) + (copy-file source target))) + '#$skeletons) + #t))) (define (assert-valid-users/groups users groups) "Raise an error if USERS refer to groups not listed in GROUPS." @@ -226,4 +229,81 @@ of user '~a' is undeclared") (user-account-supplementary-groups user))) users))) + +;;; +;;; Service. +;;; + +(define (user-group->gexp group) + "Turn GROUP, a <user-group> 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 <user-account> 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 (account-activation accounts+groups) + "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and +<user-group> objects. Raise an error if a user account refers to a undefined +group." + (define accounts + (filter user-account? accounts+groups)) + + (define user-specs + (map user-account->gexp accounts)) + + (define groups + (filter user-group? accounts+groups)) + + (define group-specs + (map user-group->gexp groups)) + + (assert-valid-users/groups accounts groups) + + ;; Add users and user groups. + #~(begin + (setenv "PATH" + (string-append #$(@ (gnu packages admin) shadow) "/sbin")) + (activate-users+groups (list #$@user-specs) + (list #$@group-specs)))) + +(define (etc-skel arguments) + "Filter out among ARGUMENTS things corresponding to skeletons, and return +the /etc/skel directory for those." + (let ((skels (filter pair? arguments))) + `(("skel" ,(skeleton-directory skels))))) + +(define account-service-type + (service-type (name 'account) + + ;; Concatenate <user-account>, <user-group>, and skeleton + ;; lists. + (compose concatenate) + (extend append) + + (extensions + (list (service-extension activation-service-type + account-activation) + (service-extension etc-service-type + etc-skel))))) + +(define (account-service accounts+groups skeletons) + "Return a <service> that takes care of user accounts and user groups, with +ACCOUNTS+GROUPS as its initial list of accounts and groups." + (service account-service-type + (append skeletons accounts+groups))) + ;;; shadow.scm ends here |