futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gnu: vm: Remove potluck hacks.

Browse Source 
* gnu/system/vm.scm (example1): Remove.
  (example2): Rename to...
  (system-qemu-image): ... this.  Add 'store' parameter, and remove call
  to 'open-connection'.
This commit is contained in:
Ludovic Courtès 2013-09-11 20:08:53 +02:00
parent a843fe2222
commit aedb72fbe0
1 changed files with 75 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

172
gnu/system/vm.scm
View File

@ -38,7 +38,8 @@
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (expression->derivation-in-linux-vm #:export (expression->derivation-in-linux-vm
qemu-image)) qemu-image
system-qemu-image))
;;; Commentary: ;;; 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?) (define* (passwd-file store accounts #:key shadow?)
"Return a password file for ACCOUNTS, a list of vectors as returned by "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 '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") (add-text-to-store store (if shadow? "shadow" "passwd")
contents '())) contents '()))
(define (example2) (define (system-qemu-image store)
(let ((store #f)) "Return the derivation of a QEMU image of the GNU system."
(dynamic-wind (define %pam-services
(lambda () ;; Services known to PAM.
(set! store (open-connection))) (list %pam-other-services
(lambda () (unix-pam-service "login" #:allow-empty-passwords? #t)))
(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))) (parameterize ((%guile-for-build (package-derivation store guile-final)))
(let* ((bash-drv (package-derivation store bash)) (let* ((bash-drv (package-derivation store bash))
(bash-file (string-append (derivation-path->output-path bash-drv) (bash-file (string-append (derivation-path->output-path bash-drv)
"/bin/bash")) "/bin/bash"))
(accounts (list (vector "root" "" 0 0 "System administrator" (accounts (list (vector "root" "" 0 0 "System administrator"
"/" bash-file))) "/" bash-file)))
(passwd (passwd-file store accounts)) (passwd (passwd-file store accounts))
(shadow (passwd-file store accounts #:shadow? #t)) (shadow (passwd-file store accounts #:shadow? #t))
(pam.d-drv (pam-services->directory store %pam-services)) (pam.d-drv (pam-services->directory store %pam-services))
(pam.d (derivation-path->output-path pam.d-drv)) (pam.d (derivation-path->output-path pam.d-drv))
(populate (populate
(add-text-to-store store "populate-qemu-image" (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 (object->string
`(begin `(begin
(mkdir-p "etc") ;; Become the session leader,
(symlink ,shadow "etc/shadow") ;; so that mingetty can do
(symlink ,passwd "etc/passwd") ;; 'TIOCSCTTY'.
(symlink "/dev/null" (setsid)
"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)) (when (zero? (primitive-fork))
(format #t "starting syslogd as ~a~%" (format #t "starting syslogd as ~a~%"
(getpid)) (getpid))
(execl ,syslogd "syslogd")) (execl ,syslogd "syslogd"))
;; Directly into mingetty. XXX ;; Directly into mingetty. XXX
;; (execl ,getty "mingetty" ;; (execl ,getty "mingetty"
;; "--noclear" "tty1") ;; "--noclear" "tty1")
(execl ,bash-file "bash"))) (execl ,bash-file "bash")))
(list out))) (list out)))
(entries (list (menu-entry (entries (list (menu-entry
(label "Boot-to-Guile! (GNU System technology preview)") (label "Boot-to-Guile! (GNU System technology preview)")
(linux linux-libre) (linux linux-libre)
(linux-arguments `("--root=/dev/vda1" (linux-arguments `("--root=/dev/vda1"
,(string-append "--load=" boot))) ,(string-append "--load=" boot)))
(initrd gnu-system-initrd)))) (initrd gnu-system-initrd))))
(grub.cfg (grub-configuration-file store entries))) (grub.cfg (grub-configuration-file store entries)))
(build-derivations store (list pam.d-drv)) (build-derivations store (list pam.d-drv))
(qemu-image store (qemu-image store
#:grub-configuration grub.cfg #:grub-configuration grub.cfg
#:populate populate #:populate populate
#:disk-image-size (* 400 (expt 2 20)) #:disk-image-size (* 400 (expt 2 20))
#:inputs-to-copy `(("boot" ,boot) #:inputs-to-copy `(("boot" ,boot)
("linux" ,linux-libre) ("linux" ,linux-libre)
("initrd" ,gnu-system-initrd) ("initrd" ,gnu-system-initrd)
("coreutils" ,coreutils) ("coreutils" ,coreutils)
("bash" ,bash) ("bash" ,bash)
("guile" ,guile-2.0) ("guile" ,guile-2.0)
("mingetty" ,mingetty) ("mingetty" ,mingetty)
("inetutils" ,inetutils) ("inetutils" ,inetutils)
;; Configuration. ;; Configuration.
("etc-pam.d" ,pam.d) ("etc-pam.d" ,pam.d)
("etc-passwd" ,passwd) ("etc-passwd" ,passwd)
("etc-shadow" ,shadow)))))) ("etc-shadow" ,shadow))))))
(lambda ()
(close-connection store)))))
;;; vm.scm ends here ;;; vm.scm ends here