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'.

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