diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/services.scm | 62 | ||||
| -rw-r--r-- | gnu/services/base.scm | 176 | ||||
| -rw-r--r-- | gnu/services/dmd.scm | 77 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 80 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 186 | ||||
| -rw-r--r-- | gnu/system.scm | 6 | ||||
| -rw-r--r-- | gnu/system/dmd.scm | 470 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 2 |
8 files changed, 587 insertions, 472 deletions
diff --git a/gnu/services.scm b/gnu/services.scm new file mode 100644 index 0000000000..eccde4e9a3 --- /dev/null +++ b/gnu/services.scm @@ -0,0 +1,62 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services) + #:use-module (guix records) + #:export (service? + service + service-documentation + service-provision + service-requirement + service-respawn? + service-start + service-stop + service-inputs + service-user-accounts + service-user-groups + service-pam-services)) + +;;; Commentary: +;;; +;;; System services as cajoled by dmd. +;;; +;;; Code: + +(define-record-type* <service> + service make-service + service? + (documentation service-documentation ; string + (default "[No documentation.]")) + (provision service-provision) ; list of symbols + (requirement service-requirement ; list of symbols + (default '())) + (respawn? service-respawn? ; Boolean + (default #t)) + (start service-start) ; expression + (stop service-stop ; expression + (default #f)) + (inputs service-inputs ; list of inputs + (default '())) + (user-accounts service-user-accounts ; list of <user-account> + (default '())) + (user-groups service-user-groups ; list of <user-groups> + (default '())) + (pam-services service-pam-services ; list of <pam-service> + (default '()))) + +;;; services.scm ends here. diff --git a/gnu/services/base.scm b/gnu/services/base.scm new file mode 100644 index 0000000000..3d684a5bec --- /dev/null +++ b/gnu/services/base.scm @@ -0,0 +1,176 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services base) + #:use-module (gnu services) + #:use-module (gnu system shadow) ; 'user-account', etc. + #:use-module (gnu system linux) ; 'pam-service', etc. + #:use-module (gnu packages admin) + #:use-module ((gnu packages base) + #:select (glibc-final)) + #:use-module (gnu packages package-management) + #:use-module (guix monads) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 format) + #:export (host-name-service + mingetty-service + nscd-service + syslog-service + guix-service)) + +;;; Commentary: +;;; +;;; Base system services---i.e., services that 99% of the users will want to +;;; use. +;;; +;;; Code: + +(define (host-name-service name) + "Return a service that sets the host name to NAME." + (with-monad %store-monad + (return (service + (documentation "Initialize the machine's host name.") + (provision '(host-name)) + (start `(lambda _ + (sethostname ,name))) + (respawn? #f))))) + +(define* (mingetty-service tty + #:key + (motd (text-file "motd" "Welcome.\n")) + (allow-empty-passwords? #t)) + "Return a service to run mingetty on TTY." + (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) + (motd motd)) + (return + (service + (documentation (string-append "Run mingetty on " tty ".")) + (provision (list (symbol-append 'term- (string->symbol tty)))) + + ;; Since the login prompt shows the host name, wait for the 'host-name' + ;; service to be done. + (requirement '(host-name)) + + (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) + (stop `(make-kill-destructor)) + (inputs `(("mingetty" ,mingetty) + ("motd" ,motd))) + + (pam-services + ;; Let 'login' be known to PAM. All the mingetty services will have + ;; that PAM service, but that's fine because they're all identical and + ;; duplicates are removed. + (list (unix-pam-service "login" + #:allow-empty-passwords? allow-empty-passwords? + #:motd motd))))))) + +(define* (nscd-service #:key (glibc glibc-final)) + "Return a service that runs libc's name service cache daemon (nscd)." + (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (return (service + (documentation "Run libc's name service cache daemon (nscd).") + (provision '(nscd)) + (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" + "--foreground")) + (stop `(make-kill-destructor)) + + (respawn? #f) + (inputs `(("glibc" ,glibc))))))) + +(define (syslog-service) + "Return a service that runs 'syslogd' with reasonable default settings." + + ;; Snippet adapted from the GNU inetutils manual. + (define contents " + # Log all kernel messages, authentication messages of + # level notice or higher and anything of level err or + # higher to the console. + # Don't log private authentication messages! + *.err;kern.*;auth.notice;authpriv.none /dev/console + + # Log anything (except mail) of level info or higher. + # Don't log private authentication messages! + *.info;mail.none;authpriv.none /var/log/messages + + # Same, in a different place. + *.info;mail.none;authpriv.none /dev/tty12 + + # The authpriv file has restricted access. + authpriv.* /var/log/secure + + # Log all the mail messages in one place. + mail.* /var/log/maillog +") + + (mlet %store-monad + ((syslog.conf (text-file "syslog.conf" contents)) + (syslogd (package-file inetutils "libexec/syslogd"))) + (return + (service + (documentation "Run the syslog daemon (syslogd).") + (provision '(syslogd)) + (start `(make-forkexec-constructor ,syslogd "--no-detach" + "--rcfile" ,syslog.conf)) + (stop `(make-kill-destructor)) + (inputs `(("inetutils" ,inetutils) + ("syslog.conf" ,syslog.conf))))))) + +(define* (guix-build-accounts count #:key + (first-uid 30001) + (gid 30000) + (shadow shadow)) + "Return a list of COUNT user accounts for Guix build users, with UIDs +starting at FIRST-UID, and under GID." + (with-monad %store-monad + (return (unfold (cut > <> count) + (lambda (n) + (user-account + (name (format #f "guixbuilder~2,'0d" n)) + (password "!") + (uid (+ first-uid n -1)) + (gid gid) + (comment (format #f "Guix Build User ~2d" n)) + (home-directory "/var/empty") + (shell (package-file shadow "sbin/nologin")) + (inputs `(("shadow" ,shadow))))) + 1+ + 1)))) + +(define* (guix-service #:key (guix guix) (builder-group "guixbuild") + (build-user-gid 30000) (build-accounts 10)) + "Return a service that runs the build daemon from GUIX, and has +BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." + (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")) + (accounts (guix-build-accounts build-accounts + #:gid build-user-gid))) + (return (service + (provision '(guix-daemon)) + (start `(make-forkexec-constructor ,daemon + "--build-users-group" + ,builder-group)) + (stop `(make-kill-destructor)) + (inputs `(("guix" ,guix))) + (user-accounts accounts) + (user-groups (list (user-group + (name builder-group) + (id build-user-gid) + (members (map user-account-name + user-accounts))))))))) + +;;; base.scm ends here diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm new file mode 100644 index 0000000000..21719118eb --- /dev/null +++ b/gnu/services/dmd.scm @@ -0,0 +1,77 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services dmd) + #:use-module (guix monads) + #:use-module (gnu services) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (dmd-configuration-file)) + +;;; Commentary: +;;; +;;; Instantiating system services as a dmd configuration file. +;;; +;;; Code: + +(define (dmd-configuration-file services etc) + "Return the dmd configuration file for SERVICES, that initializes /etc from +ETC (the name of a directory in the store) on startup." + (define config + `(begin + (use-modules (ice-9 ftw)) + + (register-services + ,@(map (lambda (service) + `(make <service> + #:docstring ',(service-documentation service) + #:provides ',(service-provision service) + #:requires ',(service-requirement service) + #:respawn? ',(service-respawn? service) + #:start ,(service-start service) + #:stop ,(service-stop service))) + services)) + + ;; /etc is a mixture of static and dynamic settings. Here is where we + ;; initialize it from the static part. + (format #t "populating /etc from ~a...~%" ,etc) + (let ((rm-f (lambda (f) + (false-if-exception (delete-file f))))) + (rm-f "/etc/static") + (symlink ,etc "/etc/static") + (for-each (lambda (file) + ;; TODO: Handle 'shadow' specially so that changed + ;; password aren't lost. + (let ((target (string-append "/etc/" file)) + (source (string-append "/etc/static/" file))) + (rm-f target) + (symlink source target))) + (scandir ,etc + (lambda (file) + (not (member file '("." "..")))))) + + ;; Prevent ETC from being GC'd. + (rm-f "/var/nix/gcroots/etc-directory") + (symlink ,etc "/var/nix/gcroots/etc-directory")) + + (format #t "starting services...~%") + (for-each start ',(append-map service-provision services)))) + + (text-file "dmd.conf" (object->string config))) + +;;; dmd.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm new file mode 100644 index 0000000000..317800db50 --- /dev/null +++ b/gnu/services/networking.scm @@ -0,0 +1,80 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services networking) + #:use-module (gnu services) + #:use-module (gnu packages admin) + #:use-module (gnu packages linux) + #:use-module (guix monads) + #:export (static-networking-service)) + +;;; Commentary: +;;; +;;; Networking services. +;;; +;;; Code: + +(define* (static-networking-service interface ip + #:key + gateway + (name-servers '()) + (inetutils inetutils) + (net-tools net-tools)) + "Return a service that starts INTERFACE with address IP. If GATEWAY is +true, it must be a string specifying the default network gateway." + + ;; TODO: Eventually we should do this using Guile's networking procedures, + ;; like 'configure-qemu-networking' does, but the patch that does this is + ;; not yet in stock Guile. + (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) + (route (package-file net-tools "sbin/route"))) + (return + (service + (documentation + (string-append "Set up networking on the '" interface + "' interface using a static IP address.")) + (provision '(networking)) + (start `(lambda _ + ;; Return #t if successfully started. + (and (zero? (system* ,ifconfig ,interface ,ip "up")) + ,(if gateway + `(zero? (system* ,route "add" "-net" "default" + "gw" ,gateway)) + #t) + ,(if (pair? name-servers) + `(call-with-output-file "/etc/resolv.conf" + (lambda (port) + (display + "# Generated by 'static-networking-service'.\n" + port) + (for-each (lambda (server) + (format port "nameserver ~a~%" + server)) + ',name-servers))) + #t)))) + (stop `(lambda _ + ;; Return #f is successfully stopped. + (not (and (system* ,ifconfig ,interface "down") + (system* ,route "del" "-net" "default"))))) + (respawn? #f) + (inputs `(("inetutils" ,inetutils) + ,@(if gateway + `(("net-tools" ,net-tools)) + '()))))))) + +;;; networking.scm ends here diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm new file mode 100644 index 0000000000..702be27714 --- /dev/null +++ b/gnu/services/xorg.scm @@ -0,0 +1,186 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services xorg) + #:use-module (gnu services) + #:use-module (gnu system linux) ; 'pam-service' + #:use-module ((gnu packages base) #:select (guile-final)) + #:use-module (gnu packages xorg) + #:use-module (gnu packages gl) + #:use-module (gnu packages slim) + #:use-module (gnu packages ratpoison) + #:use-module (gnu packages admin) + #:use-module (gnu packages bash) + #:use-module (guix monads) + #:use-module (guix derivations) + #:export (xorg-start-command + slim-service)) + +;;; Commentary: +;;; +;;; Services that relate to the X Window System. +;;; +;;; Code: + +(define* (xorg-start-command #:key + (guile guile-final) + (xorg-server xorg-server)) + "Return a derivation that builds a GUILE script to start the X server from +XORG-SERVER. Usually the X server is started by a login manager." + + (define (xserver.conf) + (text-file* "xserver.conf" " +Section \"Files\" + FontPath \"" font-adobe75dpi "/share/font/X11/75dpi\" + ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" + ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\" + ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\" + ModulePath \"" xorg-server "/lib/xorg/modules\" + ModulePath \"" xorg-server "/lib/xorg/modules/extensions\" + ModulePath \"" xorg-server "/lib/xorg/modules/multimedia\" +EndSection + +Section \"ServerFlags\" + Option \"AllowMouseOpenFail\" \"on"" +EndSection + +Section \"Monitor\" + Identifier \"Monitor[0]\" +EndSection + +Section \"InputClass\" + Identifier \"Generic keyboard\" + MatchIsKeyboard \"on\" + Option \"XkbRules\" \"base\" + Option \"XkbModel\" \"pc104\" +EndSection + +Section \"ServerLayout\" + Identifier \"Layout\" + Screen \"Screen-vesa\" +EndSection + +Section \"Device\" + Identifier \"Device-vesa\" + Driver \"vesa\" +EndSection + +Section \"Screen\" + Identifier \"Screen-vesa\" + Device \"Device-vesa\" +EndSection")) + + (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) + (xorg-bin (package-file xorg-server "bin/X")) + (dri (package-file mesa "lib/dri")) + (xkbcomp-bin (package-file xkbcomp "bin")) + (xkb-dir (package-file xkeyboard-config + "share/X11/xkb")) + (config (xserver.conf))) + (define builder + ;; Write a small wrapper around the X server. + `(let ((out (assoc-ref %outputs "out"))) + (call-with-output-file out + (lambda (port) + (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) + (write '(begin + (setenv "XORG_DRI_DRIVER_PATH" ,dri) + (setenv "XKB_BINDIR" ,xkbcomp-bin) + + (apply execl + + ,xorg-bin "-ac" "-logverbose" "-verbose" + "-xkbdir" ,xkb-dir + "-config" ,(derivation->output-path config) + "-nolisten" "tcp" "-terminate" + + ;; Note: SLiM and other display managers add the + ;; '-auth' flag by themselves. + (cdr (command-line)))) + port))) + (chmod out #o555) + #t)) + + (mlet %store-monad ((inputs (lower-inputs + `(("xorg" ,xorg-server) + ("xkbcomp" ,xkbcomp) + ("xkeyboard-config" ,xkeyboard-config) + ("mesa" ,mesa) + ("guile" ,guile) + ("xorg.conf" ,config))))) + (derivation-expression "start-xorg" builder + #:inputs inputs)))) + +(define* (slim-service #:key (slim slim) + (allow-empty-passwords? #t) auto-login? + (default-user "") + (xauth xauth) (dmd dmd) (bash bash) + startx) + "Return a service that spawns the SLiM graphical login manager, which in +turn start the X display server with STARTX, a command as returned by +'xorg-start-command'. + +When ALLOW-EMPTY-PASSWORDS? is true, allow logins with an empty password. +When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." + (define (slim.cfg) + ;; TODO: Run "bash -login ~/.xinitrc %session". + (mlet %store-monad ((startx (or startx (xorg-start-command)))) + (text-file* "slim.cfg" " +default_path /run/current-system/bin +default_xserver " startx " +xserver_arguments :0 vt7 +xauth_path " xauth "/bin/xauth +authfile /var/run/slim.auth + +# The login command. '%session' is replaced by the chosen session name, one +# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. +login_cmd exec " ratpoison "/bin/ratpoison + +halt_cmd " dmd "/sbin/halt +reboot_cmd " dmd "/sbin/reboot +" (if auto-login? + (string-append "auto_login yes\ndefault_user " default-user) + "")))) + + (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) + (bash-bin (package-file bash "bin/bash")) + (slim.cfg (slim.cfg))) + (return + (service + (documentation "Xorg display server") + (provision '(xorg-server)) + (requirement '(host-name)) + (start + ;; XXX: Work around the inability to specify env. vars. directly. + `(make-forkexec-constructor + ,bash-bin "-c" + ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) + " " slim-bin + " -nodaemon"))) + (stop `(make-kill-destructor)) + (inputs `(("slim" ,slim) + ("slim.cfg" ,slim.cfg) + ("bash" ,bash))) + (respawn? #t) + (pam-services + ;; Tell PAM about 'slim'. + (list (unix-pam-service + "slim" + #:allow-empty-passwords? allow-empty-passwords?))))))) + +;;; xorg.scm ends here diff --git a/gnu/system.scm b/gnu/system.scm index 6918d5bcb8..f05b7a092a 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -26,7 +26,11 @@ #:use-module (gnu packages bash) #:use-module (gnu packages admin) #:use-module (gnu packages package-management) - #:use-module (gnu system dmd) + #:use-module (gnu services) + #:use-module (gnu services dmd) + #:use-module (gnu services base) + #:use-module ((gnu services networking) + #:select (static-networking-service)) #:use-module (gnu system grub) #:use-module (gnu system shadow) #:use-module (gnu system linux) diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm deleted file mode 100644 index c1ddec88d6..0000000000 --- a/gnu/system/dmd.scm +++ /dev/null @@ -1,470 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -(define-module (gnu system dmd) - #:use-module (guix store) - #:use-module (guix packages) - #:use-module (guix derivations) - #:use-module (guix records) - #:use-module ((gnu packages base) - #:select (glibc-final guile-final)) - #:use-module ((gnu packages admin) - #:select (dmd mingetty inetutils shadow)) - #:use-module ((gnu packages package-management) - #:select (guix)) - #:use-module ((gnu packages linux) - #:select (net-tools)) - #:use-module (gnu packages xorg) - #:use-module (gnu packages bash) - #:use-module (gnu packages gl) - #:use-module (gnu packages slim) - #:use-module (gnu packages ratpoison) - - #:use-module (gnu system shadow) ; for user accounts/groups - #:use-module (gnu system linux) ; for PAM services - #:use-module (ice-9 match) - #:use-module (ice-9 format) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (guix monads) - #:export (service? - service - service-provision - service-requirement - service-respawn? - service-start - service-stop - service-inputs - service-user-accounts - service-user-groups - service-pam-services - - host-name-service - syslog-service - mingetty-service - nscd-service - guix-service - static-networking-service - xorg-start-command - slim-service - - dmd-configuration-file)) - -;;; Commentary: -;;; -;;; System services as cajoled by dmd. -;;; -;;; Code: - -(define-record-type* <service> - service make-service - service? - (documentation service-documentation ; string - (default "[No documentation.]")) - (provision service-provision) ; list of symbols - (requirement service-requirement ; list of symbols - (default '())) - (respawn? service-respawn? ; Boolean - (default #t)) - (start service-start) ; expression - (stop service-stop ; expression - (default #f)) - (inputs service-inputs ; list of inputs - (default '())) - (user-accounts service-user-accounts ; list of <user-account> - (default '())) - (user-groups service-user-groups ; list of <user-groups> - (default '())) - (pam-services service-pam-services ; list of <pam-service> - (default '()))) - -(define (host-name-service name) - "Return a service that sets the host name to NAME." - (with-monad %store-monad - (return (service - (documentation "Initialize the machine's host name.") - (provision '(host-name)) - (start `(lambda _ - (sethostname ,name))) - (respawn? #f))))) - -(define* (mingetty-service tty - #:key - (motd (text-file "motd" "Welcome.\n")) - (allow-empty-passwords? #t)) - "Return a service to run mingetty on TTY." - (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) - (motd motd)) - (return - (service - (documentation (string-append "Run mingetty on " tty ".")) - (provision (list (symbol-append 'term- (string->symbol tty)))) - - ;; Since the login prompt shows the host name, wait for the 'host-name' - ;; service to be done. - (requirement '(host-name)) - - (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) - (stop `(make-kill-destructor)) - (inputs `(("mingetty" ,mingetty) - ("motd" ,motd))) - - (pam-services - ;; Let 'login' be known to PAM. All the mingetty services will have - ;; that PAM service, but that's fine because they're all identical and - ;; duplicates are removed. - (list (unix-pam-service "login" - #:allow-empty-passwords? allow-empty-passwords? - #:motd motd))))))) - -(define* (nscd-service #:key (glibc glibc-final)) - "Return a service that runs libc's name service cache daemon (nscd)." - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) - (return (service - (documentation "Run libc's name service cache daemon (nscd).") - (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) - - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) - -(define (syslog-service) - "Return a service that runs 'syslogd' with reasonable default settings." - - ;; Snippet adapted from the GNU inetutils manual. - (define contents " - # Log all kernel messages, authentication messages of - # level notice or higher and anything of level err or - # higher to the console. - # Don't log private authentication messages! - *.err;kern.*;auth.notice;authpriv.none /dev/console - - # Log anything (except mail) of level info or higher. - # Don't log private authentication messages! - *.info;mail.none;authpriv.none /var/log/messages - - # Same, in a different place. - *.info;mail.none;authpriv.none /dev/tty12 - - # The authpriv file has restricted access. - authpriv.* /var/log/secure - - # Log all the mail messages in one place. - mail.* /var/log/maillog -") - - (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents)) - (syslogd (package-file inetutils "libexec/syslogd"))) - (return - (service - (documentation "Run the syslog daemon (syslogd).") - (provision '(syslogd)) - (start `(make-forkexec-constructor ,syslogd "--no-detach" - "--rcfile" ,syslog.conf)) - (stop `(make-kill-destructor)) - (inputs `(("inetutils" ,inetutils) - ("syslog.conf" ,syslog.conf))))))) - -(define* (guix-build-accounts count #:key - (first-uid 30001) - (gid 30000) - (shadow shadow)) - "Return a list of COUNT user accounts for Guix build users, with UIDs -starting at FIRST-UID, and under GID." - (with-monad %store-monad - (return (unfold (cut > <> count) - (lambda (n) - (user-account - (name (format #f "guixbuilder~2,'0d" n)) - (password "!") - (uid (+ first-uid n -1)) - (gid gid) - (comment (format #f "Guix Build User ~2d" n)) - (home-directory "/var/empty") - (shell (package-file shadow "sbin/nologin")) - (inputs `(("shadow" ,shadow))))) - 1+ - 1)))) - -(define* (guix-service #:key (guix guix) (builder-group "guixbuild") - (build-user-gid 30000) (build-accounts 10)) - "Return a service that runs the build daemon from GUIX, and has -BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." - (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")) - (accounts (guix-build-accounts build-accounts - #:gid build-user-gid))) - (return (service - (provision '(guix-daemon)) - (start `(make-forkexec-constructor ,daemon - "--build-users-group" - ,builder-group)) - (stop `(make-kill-destructor)) - (inputs `(("guix" ,guix))) - (user-accounts accounts) - (user-groups (list (user-group - (name builder-group) - (id build-user-gid) - (members (map user-account-name - user-accounts))))))))) - -(define* (static-networking-service interface ip - #:key - gateway - (name-servers '()) - (inetutils inetutils) - (net-tools net-tools)) - "Return a service that starts INTERFACE with address IP. If GATEWAY is -true, it must be a string specifying the default network gateway." - - ;; TODO: Eventually we should do this using Guile's networking procedures, - ;; like 'configure-qemu-networking' does, but the patch that does this is - ;; not yet in stock Guile. - (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) - (route (package-file net-tools "sbin/route"))) - (return - (service - (documentation - (string-append "Set up networking on the '" interface - "' interface using a static IP address.")) - (provision '(networking)) - (start `(lambda _ - ;; Return #t if successfully started. - (and (zero? (system* ,ifconfig ,interface ,ip "up")) - ,(if gateway - `(zero? (system* ,route "add" "-net" "default" - "gw" ,gateway)) - #t) - ,(if (pair? name-servers) - `(call-with-output-file "/etc/resolv.conf" - (lambda (port) - (display - "# Generated by 'static-networking-service'.\n" - port) - (for-each (lambda (server) - (format port "nameserver ~a~%" - server)) - ',name-servers))) - #t)))) - (stop `(lambda _ - ;; Return #f is successfully stopped. - (not (and (system* ,ifconfig ,interface "down") - (system* ,route "del" "-net" "default"))))) - (respawn? #f) - (inputs `(("inetutils" ,inetutils) - ,@(if gateway - `(("net-tools" ,net-tools)) - '()))))))) - -(define* (xorg-start-command #:key - (guile guile-final) - (xorg-server xorg-server)) - "Return a derivation that builds a GUILE script to start the X server from -XORG-SERVER. Usually the X server is started by a login manager." - - (define (xserver.conf) - (text-file* "xserver.conf" " -Section \"Files\" - FontPath \"" font-adobe75dpi "/share/font/X11/75dpi\" - ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" - ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\" - ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\" - ModulePath \"" xorg-server "/lib/xorg/modules\" - ModulePath \"" xorg-server "/lib/xorg/modules/extensions\" - ModulePath \"" xorg-server "/lib/xorg/modules/multimedia\" -EndSection - -Section \"ServerFlags\" - Option \"AllowMouseOpenFail\" \"on"" -EndSection - -Section \"Monitor\" - Identifier \"Monitor[0]\" -EndSection - -Section \"InputClass\" - Identifier \"Generic keyboard\" - MatchIsKeyboard \"on\" - Option \"XkbRules\" \"base\" - Option \"XkbModel\" \"pc104\" -EndSection - -Section \"ServerLayout\" - Identifier \"Layout\" - Screen \"Screen-vesa\" -EndSection - -Section \"Device\" - Identifier \"Device-vesa\" - Driver \"vesa\" -EndSection - -Section \"Screen\" - Identifier \"Screen-vesa\" - Device \"Device-vesa\" -EndSection")) - - (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) - (xorg-bin (package-file xorg-server "bin/X")) - (dri (package-file mesa "lib/dri")) - (xkbcomp-bin (package-file xkbcomp "bin")) - (xkb-dir (package-file xkeyboard-config - "share/X11/xkb")) - (config (xserver.conf))) - (define builder - ;; Write a small wrapper around the X server. - `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) - (write '(begin - (setenv "XORG_DRI_DRIVER_PATH" ,dri) - (setenv "XKB_BINDIR" ,xkbcomp-bin) - - (apply execl - - ,xorg-bin "-ac" "-logverbose" "-verbose" - "-xkbdir" ,xkb-dir - "-config" ,(derivation->output-path config) - "-nolisten" "tcp" "-terminate" - - ;; Note: SLiM and other display managers add the - ;; '-auth' flag by themselves. - (cdr (command-line)))) - port))) - (chmod out #o555) - #t)) - - (mlet %store-monad ((inputs (lower-inputs - `(("xorg" ,xorg-server) - ("xkbcomp" ,xkbcomp) - ("xkeyboard-config" ,xkeyboard-config) - ("mesa" ,mesa) - ("guile" ,guile) - ("xorg.conf" ,config))))) - (derivation-expression "start-xorg" builder - #:inputs inputs)))) - -(define* (slim-service #:key (slim slim) - (allow-empty-passwords? #t) auto-login? - (default-user "") - (xauth xauth) (dmd dmd) (bash bash) - startx) - "Return a service that spawns the SLiM graphical login manager, which in -turn start the X display server with STARTX, a command as returned by -'xorg-start-command'. - -When ALLOW-EMPTY-PASSWORDS? is true, allow logins with an empty password. -When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." - (define (slim.cfg) - ;; TODO: Run "bash -login ~/.xinitrc %session". - (mlet %store-monad ((startx (or startx (xorg-start-command)))) - (text-file* "slim.cfg" " -default_path /run/current-system/bin -default_xserver " startx " -xserver_arguments :0 vt7 -xauth_path " xauth "/bin/xauth -authfile /var/run/slim.auth - -# The login command. '%session' is replaced by the chosen session name, one -# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. -login_cmd exec " ratpoison "/bin/ratpoison - -halt_cmd " dmd "/sbin/halt -reboot_cmd " dmd "/sbin/reboot -" (if auto-login? - (string-append "auto_login yes\ndefault_user " default-user) - "")))) - - (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) - (bash-bin (package-file bash "bin/bash")) - (slim.cfg (slim.cfg))) - (return - (service - (documentation "Xorg display server") - (provision '(xorg-server)) - (requirement '(host-name)) - (start - ;; XXX: Work around the inability to specify env. vars. directly. - `(make-forkexec-constructor - ,bash-bin "-c" - ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) - " " slim-bin - " -nodaemon"))) - (stop `(make-kill-destructor)) - (inputs `(("slim" ,slim) - ("slim.cfg" ,slim.cfg) - ("bash" ,bash))) - (respawn? #t) - (pam-services - ;; Tell PAM about 'slim'. - (list (unix-pam-service - "slim" - #:allow-empty-passwords? allow-empty-passwords?))))))) - - -(define (dmd-configuration-file services etc) - "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC on startup." - (define config - `(begin - (use-modules (ice-9 ftw)) - - (register-services - ,@(map (match-lambda - (($ <service> documentation provision requirement - respawn? start stop) - `(make <service> - #:docstring ,documentation - #:provides ',provision - #:requires ',requirement - #:respawn? ,respawn? - #:start ,start - #:stop ,stop))) - services)) - - ;; /etc is a mixture of static and dynamic settings. Here is where we - ;; initialize it from the static part. - (format #t "populating /etc from ~a...~%" ,etc) - (let ((rm-f (lambda (f) - (false-if-exception (delete-file f))))) - (rm-f "/etc/static") - (symlink ,etc "/etc/static") - (for-each (lambda (file) - ;; TODO: Handle 'shadow' specially so that changed - ;; password aren't lost. - (let ((target (string-append "/etc/" file)) - (source (string-append "/etc/static/" file))) - (rm-f target) - (symlink source target))) - (scandir ,etc - (lambda (file) - (not (member file '("." "..")))))) - - ;; Prevent ETC from being GC'd. - (rm-f "/var/nix/gcroots/etc-directory") - (symlink ,etc "/var/nix/gcroots/etc-directory")) - - (format #t "starting services...~%") - (for-each start ',(append-map service-provision services)))) - - (text-file "dmd.conf" (object->string config))) - -;;; dmd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index dea7d0599b..3c0ea8a351 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -44,8 +44,8 @@ #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) #:use-module (gnu system grub) - #:use-module (gnu system dmd) #:use-module (gnu system) + #:use-module (gnu services) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) |