From 4646e30a7a1588d37814d6c78d27302f80783583 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 21 Sep 2013 01:08:42 +0200
Subject: 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.
---
 gnu/system/dmd.scm | 126 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 126 insertions(+)
 create mode 100644 gnu/system/dmd.scm

(limited to 'gnu/system/dmd.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
-- 
cgit v1.2.3