summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu-system.am1
-rw-r--r--gnu/system/dmd.scm126
-rw-r--r--gnu/system/vm.scm51
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