ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-23 02:59:17 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu: QEMU images boots into dmd.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2013-09-21 01:08:42 +02:00
parent f15164e791
commit 4646e30a7a
3 changed files with 154 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
gnu-system.am
View file

@ -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 \

126
gnu/system/dmd.scm Normal file
View file

@ -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

51
gnu/system/vm.scm
View file

@ -38,6 +38,7 @@ (define-module (gnu system vm)
#: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 @@ (define %pam-services
(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 @@ (define %pam-services
(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 @@ (define %pam-services
(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 @@ (define %pam-services
("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