diff options
| -rw-r--r-- | gnu-system.am | 1 | ||||
| -rw-r--r-- | gnu/system/dmd.scm | 126 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 51 |
3 files changed, 154 insertions, 24 deletions
diff --git a/gnu-system.am b/gnu-system.am index 4069301fe7..3809cb7ad3 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -180,6 +180,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/zile.scm \ gnu/packages/zip.scm \ \ + gnu/system/dmd.scm \ gnu/system/grub.scm \ gnu/system/linux.scm \ gnu/system/shadow.scm \ diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm new file mode 100644 index 0000000000..1e8767e357 --- /dev/null +++ b/gnu/system/dmd.scm @@ -0,0 +1,126 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 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 system) + #:select (mingetty inetutils)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (service? + service + service-provision + service-requirement + service-respawn? + service-start + service-stop + service-inputs + + syslog-service + mingetty-service + dmd-configuration-file)) + +;;; Commentary: +;;; +;;; System services as cajoled by dmd. +;;; +;;; Code: + +(define-record-type* <service> + service make-service + service? + (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 '()))) + +(define (mingetty-service store tty) + "Return a service to run mingetty on TTY." + (let* ((mingetty-drv (package-derivation store mingetty)) + (mingetty-bin (string-append (derivation->output-path mingetty-drv) + "/sbin/mingetty"))) + (service + (provision (list (symbol-append 'term- (string->symbol tty)))) + (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) + (inputs `(("mingetty" ,mingetty)))))) + +(define (syslog-service store) + "Return a service that runs 'syslogd' with reasonable default settings." + + (define syslog.conf + ;; Snippet adapted from the GNU inetutils manual. + (add-text-to-store store "syslog.conf" " + # 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 +")) + + (let* ((inetutils-drv (package-derivation store inetutils)) + (syslogd (string-append (derivation->output-path inetutils-drv) + "/libexec/syslogd"))) + (service + (provision '(syslogd)) + (start `(make-forkexec-constructor ,syslogd + "--rcfile" ,syslog.conf)) + (inputs `(("inetutils" ,inetutils) + ("syslog.conf" ,syslog.conf)))))) + +(define (dmd-configuration-file store services) + "Return the dmd configuration file for SERVICES." + (define config + `(begin + (register-services + ,@(map (match-lambda + (($ <service> provision requirement respawn? start stop) + `(make <service> + #:provides ',provision + #:requires ',requirement + #:respawn? ,respawn? + #:start ,start + #:stop ,stop))) + services)) + (for-each start ',(append-map service-provision services)))) + + (add-text-to-store store "dmd.conf" + (object->string config))) + +;;; dmd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 68d205d82a..df55f7c94e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -38,6 +38,7 @@ #:use-module (gnu system shadow) #:use-module (gnu system linux) #:use-module (gnu system grub) + #:use-module (gnu system dmd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -359,14 +360,27 @@ It can be used to provide additional files, such as /etc files." (list %pam-other-services (unix-pam-service "login" #:allow-empty-passwords? #t))) + (define %dmd-services + ;; Services run by dmd. + (list (mingetty-service store "tty1") + (mingetty-service store "tty2") + (mingetty-service store "tty3") + (syslog-service store))) + (parameterize ((%guile-for-build (package-derivation store guile-final))) (let* ((bash-drv (package-derivation store bash)) (bash-file (string-append (derivation->output-path bash-drv) "/bin/bash")) + (dmd-drv (package-derivation store dmd)) + (dmd-file (string-append (derivation->output-path dmd-drv) + "/bin/dmd")) + (dmd-conf (dmd-configuration-file store %dmd-services)) (accounts (list (vector "root" "" 0 0 "System administrator" "/" bash-file))) (passwd (passwd-file store accounts)) (shadow (passwd-file store accounts #:shadow? #t)) + (group (add-text-to-store store "group" + "root:x:0:\n")) (pam.d-drv (pam-services->directory store %pam-services)) (pam.d (derivation->output-path pam.d-drv)) (populate @@ -374,8 +388,10 @@ It can be used to provide additional files, such as /etc files." (object->string `(begin (mkdir-p "etc") + (mkdir-p "var/log") ; for dmd (symlink ,shadow "etc/shadow") (symlink ,passwd "etc/passwd") + (symlink ,group "etc/group") (symlink "/dev/null" "etc/login.defs") (symlink ,pam.d "etc/pam.d") @@ -383,28 +399,11 @@ It can be used to provide additional files, such as /etc files." (list passwd))) (out (derivation->output-path (package-derivation store mingetty))) - (getty (string-append out "/sbin/mingetty")) - (iu-drv (package-derivation store inetutils)) - (syslogd (string-append (derivation->output-path iu-drv) - "/libexec/syslogd")) - (boot (add-text-to-store store "boot" - (object->string - `(begin - ;; Become the session leader, - ;; so that mingetty can do - ;; 'TIOCSCTTY'. - (setsid) - - (when (zero? (primitive-fork)) - (format #t "starting syslogd as ~a~%" - (getpid)) - (execl ,syslogd "syslogd")) - - ;; Directly into mingetty. XXX - ;; (execl ,getty "mingetty" - ;; "--noclear" "tty1") - (execl ,bash-file "bash"))) - (list out))) + (boot (add-text-to-store store "boot" + (object->string + `(execl ,dmd-file "dmd" + "--config" ,dmd-conf)) + (list out))) (entries (list (menu-entry (label "Boot-to-Guile! (GNU System technology preview)") (linux linux-libre) @@ -424,11 +423,15 @@ It can be used to provide additional files, such as /etc files." ("bash" ,bash) ("guile" ,guile-2.0) ("mingetty" ,mingetty) - ("inetutils" ,inetutils) + ("dmd" ,dmd) ;; Configuration. + ("dmd.conf" ,dmd-conf) ("etc-pam.d" ,pam.d) ("etc-passwd" ,passwd) - ("etc-shadow" ,shadow)))))) + ("etc-shadow" ,shadow) + ("etc-group" ,group) + ,@(append-map service-inputs + %dmd-services)))))) ;;; vm.scm ends here |