gnu: QEMU images boots into dmd.

* gnu/system/dmd.scm: New file.
* gnu/system/vm.scm (system-qemu-image): Define dmd services.
  [populate]: Make var/log and etc/group.
  [boot]: Execute dmd directly.
  Add dmd and etc-group as inputs; add the inputs of dmd services.
* gnu-system.am (GNU_SYSTEM_MODULES): Add gnu/system/dmd.scm.

2 files changed, 153 insertions, 24 deletions

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