aboutsummaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-09-11 20:08:53 +0200
committerLudovic Courtès <ludo@gnu.org>2013-09-11 20:27:36 +0200
commitaedb72fbe07b82da00f6c7a397794d465c217135 (patch)
tree5f559722b40aa24686403eb471d247233281e1ce /gnu/system
parenta843fe2222fec5f162a94da8836b803cd7e0c7ff (diff)
downloadguix-aedb72fbe07b82da00f6c7a397794d465c217135.tar
guix-aedb72fbe07b82da00f6c7a397794d465c217135.tar.gz
gnu: vm: Remove potluck hacks.
* gnu/system/vm.scm (example1): Remove. (example2): Rename to... (system-qemu-image): ... this. Add 'store' parameter, and remove call to 'open-connection'.
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/vm.scm180
1 files changed, 79 insertions, 101 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 28d22efdc3..6886e67c21 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -38,7 +38,8 @@
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (expression->derivation-in-linux-vm
- qemu-image))
+ qemu-image
+ system-qemu-image))
;;; Commentary:
@@ -342,26 +343,9 @@ It can be used to provide additional files, such as /etc files."
;;;
-;;; Guile 2.0 potluck examples.
+;;; Stand-alone VM image.
;;;
-(define (example1)
- (let ((store #f))
- (dynamic-wind
- (lambda ()
- (set! store (open-connection)))
- (lambda ()
- (parameterize ((%guile-for-build (package-derivation store guile-final)))
- (expression->derivation-in-linux-vm
- store "vm-test"
- '(begin
- (display "hello from boot!\n")
- (call-with-output-file "/xchg/hello"
- (lambda (p)
- (display "world" p)))))))
- (lambda ()
- (close-connection store)))))
-
(define* (passwd-file store accounts #:key shadow?)
"Return a password file for ACCOUNTS, a list of vectors as returned by
'getpwnam'. If SHADOW? is true, then it is a /etc/shadow file, otherwise it
@@ -389,89 +373,83 @@ is a /etc/passwd file."
(add-text-to-store store (if shadow? "shadow" "passwd")
contents '()))
-(define (example2)
- (let ((store #f))
- (dynamic-wind
- (lambda ()
- (set! store (open-connection)))
- (lambda ()
- (define %pam-services
- ;; Services known to PAM.
- (list %pam-other-services
- (unix-pam-service "login" #:allow-empty-passwords? #t)))
-
- (parameterize ((%guile-for-build (package-derivation store guile-final)))
- (let* ((bash-drv (package-derivation store bash))
- (bash-file (string-append (derivation-path->output-path bash-drv)
- "/bin/bash"))
- (accounts (list (vector "root" "" 0 0 "System administrator"
- "/" bash-file)))
- (passwd (passwd-file store accounts))
- (shadow (passwd-file store accounts #:shadow? #t))
- (pam.d-drv (pam-services->directory store %pam-services))
- (pam.d (derivation-path->output-path pam.d-drv))
- (populate
- (add-text-to-store store "populate-qemu-image"
+(define (system-qemu-image store)
+ "Return the derivation of a QEMU image of the GNU system."
+ (define %pam-services
+ ;; Services known to PAM.
+ (list %pam-other-services
+ (unix-pam-service "login" #:allow-empty-passwords? #t)))
+
+ (parameterize ((%guile-for-build (package-derivation store guile-final)))
+ (let* ((bash-drv (package-derivation store bash))
+ (bash-file (string-append (derivation-path->output-path bash-drv)
+ "/bin/bash"))
+ (accounts (list (vector "root" "" 0 0 "System administrator"
+ "/" bash-file)))
+ (passwd (passwd-file store accounts))
+ (shadow (passwd-file store accounts #:shadow? #t))
+ (pam.d-drv (pam-services->directory store %pam-services))
+ (pam.d (derivation-path->output-path pam.d-drv))
+ (populate
+ (add-text-to-store store "populate-qemu-image"
+ (object->string
+ `(begin
+ (mkdir-p "etc")
+ (symlink ,shadow "etc/shadow")
+ (symlink ,passwd "etc/passwd")
+ (symlink "/dev/null"
+ "etc/login.defs")
+ (symlink ,pam.d "etc/pam.d")
+ (mkdir-p "var/run")))
+ (list passwd)))
+ (out (derivation-path->output-path
+ (package-derivation store mingetty)))
+ (getty (string-append out "/sbin/mingetty"))
+ (iu-drv (package-derivation store inetutils))
+ (syslogd (string-append (derivation-path->output-path iu-drv)
+ "/libexec/syslogd"))
+ (boot (add-text-to-store store "boot"
(object->string
`(begin
- (mkdir-p "etc")
- (symlink ,shadow "etc/shadow")
- (symlink ,passwd "etc/passwd")
- (symlink "/dev/null"
- "etc/login.defs")
- (symlink ,pam.d "etc/pam.d")
- (mkdir-p "var/run")))
- (list passwd)))
- (out (derivation-path->output-path
- (package-derivation store mingetty)))
- (getty (string-append out "/sbin/mingetty"))
- (iu-drv (package-derivation store inetutils))
- (syslogd (string-append (derivation-path->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)))
- (entries (list (menu-entry
- (label "Boot-to-Guile! (GNU System technology preview)")
- (linux linux-libre)
- (linux-arguments `("--root=/dev/vda1"
- ,(string-append "--load=" boot)))
- (initrd gnu-system-initrd))))
- (grub.cfg (grub-configuration-file store entries)))
- (build-derivations store (list pam.d-drv))
- (qemu-image store
- #:grub-configuration grub.cfg
- #:populate populate
- #:disk-image-size (* 400 (expt 2 20))
- #:inputs-to-copy `(("boot" ,boot)
- ("linux" ,linux-libre)
- ("initrd" ,gnu-system-initrd)
- ("coreutils" ,coreutils)
- ("bash" ,bash)
- ("guile" ,guile-2.0)
- ("mingetty" ,mingetty)
- ("inetutils" ,inetutils)
-
- ;; Configuration.
- ("etc-pam.d" ,pam.d)
- ("etc-passwd" ,passwd)
- ("etc-shadow" ,shadow))))))
- (lambda ()
- (close-connection store)))))
+ ;; 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)))
+ (entries (list (menu-entry
+ (label "Boot-to-Guile! (GNU System technology preview)")
+ (linux linux-libre)
+ (linux-arguments `("--root=/dev/vda1"
+ ,(string-append "--load=" boot)))
+ (initrd gnu-system-initrd))))
+ (grub.cfg (grub-configuration-file store entries)))
+ (build-derivations store (list pam.d-drv))
+ (qemu-image store
+ #:grub-configuration grub.cfg
+ #:populate populate
+ #:disk-image-size (* 400 (expt 2 20))
+ #:inputs-to-copy `(("boot" ,boot)
+ ("linux" ,linux-libre)
+ ("initrd" ,gnu-system-initrd)
+ ("coreutils" ,coreutils)
+ ("bash" ,bash)
+ ("guile" ,guile-2.0)
+ ("mingetty" ,mingetty)
+ ("inetutils" ,inetutils)
+
+ ;; Configuration.
+ ("etc-pam.d" ,pam.d)
+ ("etc-passwd" ,passwd)
+ ("etc-shadow" ,shadow))))))
;;; vm.scm ends here