[jackhill/guix/guix.git] / gnu / system / vm.scm

;;; 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 vm)
  #:use-module (guix config)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module ((gnu packages base) #:select (%final-inputs
                                              guile-final
                                              coreutils))
  #:use-module (gnu packages guile)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages qemu)
  #:use-module (gnu packages parted)
  #:use-module (gnu packages grub)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages linux-initrd)
  #:use-module ((gnu packages make-bootstrap)
                #:select (%guile-static-stripped))
  #:use-module ((gnu packages system)
                #:select (mingetty))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (expression->derivation-in-linux-vm
            qemu-image))

\f
;;; Commentary:
;;;
;;; Tools to evaluate build expressions within virtual machines.
;;;
;;; Code:

(define* (expression->derivation-in-linux-vm store name exp
                                             #:key
                                             (system (%current-system))
                                             (inputs '())
                                             (linux linux-libre)
                                             (initrd qemu-initrd)
                                             (qemu qemu/smb-shares)
                                             (env-vars '())
                                             (modules '())
                                             (guile-for-build
                                              (%guile-for-build))

                                             (make-disk-image? #f)
                                             (references-graphs #f)
                                             (disk-image-size
                                              (* 100 (expt 2 20))))
  "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD.  In the
virtual machine, EXP has access to all of INPUTS from the store; it should put
its output files in the `/xchg' directory, which is copied to the derivation's
output when the VM terminates.

When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
DISK-IMAGE-SIZE bytes and return it.

When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'.  The files containing the reference graphs are
made available under the /xchg CIFS share."
  (define input-alist
    (map (match-lambda
          ((input (? package? package))
           `(,input . ,(package-output store package "out" system)))
          ((input (? package? package) sub-drv)
           `(,input . ,(package-output store package sub-drv system)))
          ((input (and (? string?) (? store-path?) file))
           `(,input . ,file)))
         inputs))

  (define exp*
    ;; EXP, but with INPUTS available.
    `(let ((%build-inputs ',input-alist))
       ,exp))

  (define builder
    ;; Code that launches the VM that evaluates EXP.
    `(let ()
       (use-modules (guix build utils)
                    (srfi srfi-1)
                    (ice-9 rdelim))

       (let ((out     (assoc-ref %outputs "out"))
             (cu      (string-append (assoc-ref %build-inputs "coreutils")
                                     "/bin"))
             (qemu    (string-append (assoc-ref %build-inputs "qemu")
                                     "/bin/qemu-system-"
                                     (car (string-split ,system #\-))))
             (img     (string-append (assoc-ref %build-inputs "qemu")
                                     "/bin/qemu-img"))
             (linux   (string-append (assoc-ref %build-inputs "linux")
                                     "/bzImage"))
             (initrd  (string-append (assoc-ref %build-inputs "initrd")
                                     "/initrd"))
             (builder (assoc-ref %build-inputs "builder")))

         ;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB
         ;; directory, so it really needs `rm' in $PATH.
         (setenv "PATH" cu)

         ,(if make-disk-image?
              `(zero? (system* img "create" "image.qcow2"
                               ,(number->string disk-image-size)))
              '(begin))

         (mkdir "xchg")

         ;; Copy the reference-graph files under xchg/ so EXP can access it.
         (begin
           ,@(match references-graphs
               (((graph-files . _) ...)
                (map (lambda (file)
                       `(copy-file ,file
                                   ,(string-append "xchg/" file)))
                     graph-files))
               (#f '())))

         (and (zero?
               (system* qemu "-nographic" "-no-reboot"
                        "-net" "nic,model=e1000"
                        "-net" (string-append "user,smb=" (getcwd))
                        "-kernel" linux
                        "-initrd" initrd
                        "-append" (string-append "console=ttyS0 --load="
                                                 builder)
                        ,@(if make-disk-image?
                              '("-hda" "image.qcow2")
                              '())))
              ,(if make-disk-image?
                   '(copy-file "image.qcow2"      ; XXX: who mkdir'd OUT?
                               out)
                   '(begin
                      (mkdir out)
                      (copy-recursively "xchg" out)))))))

  (let ((user-builder (add-text-to-store store "builder-in-linux-vm"
                                         (object->string exp*)
                                         '()))
        (->drv        (cut package-derivation store <> system))
        (coreutils    (car (assoc-ref %final-inputs "coreutils"))))
    (build-expression->derivation store name system builder
                                  `(("qemu" ,(->drv qemu))
                                    ("linux" ,(->drv linux))
                                    ("initrd" ,(->drv initrd))
                                    ("coreutils" ,(->drv coreutils))
                                    ("builder" ,user-builder)
                                    ,@(map (match-lambda
                                            ((name (? package? package)
                                                   sub-drv ...)
                                             `(,name ,(->drv package)
                                                     ,@sub-drv))
                                            ((name (? string? file))
                                             `(,name ,file)))
                                           inputs))
                                  #:env-vars env-vars
                                  #:modules (delete-duplicates
                                             `((guix build utils)
                                               ,@modules))
                                  #:guile-for-build guile-for-build
                                  #:references-graphs references-graphs)))

(define* (qemu-image store #:key
                     (name "qemu-image")
                     (system (%current-system))
                     (disk-image-size (* 100 (expt 2 20)))
                     (linux linux-libre)
                     (linux-arguments '())
                     (initrd qemu-initrd)
                     (inputs '())
                     (inputs-to-copy '())
                     (boot-expression #f))
  "Return a bootable, stand-alone QEMU image.  The returned image is a full
disk image, with a GRUB installation whose default entry boots LINUX, with the
arguments LINUX-ARGUMENTS, and using INITRD as its initial RAM disk.

INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
into the image being built.

When BOOT-EXPRESSION is true, it is an expression to evaluate when the basic
initialization is done.  A typical example is `(execl ...)' to launch the init
process."
  (define input->name+derivation
    (match-lambda
     ((name (? package? package))
      `(,name . ,(derivation-path->output-path
                  (package-derivation store package system))))
     ((name (? package? package) sub-drv)
      `(,name . ,(derivation-path->output-path
                  (package-derivation store package system)
                  sub-drv)))
     ((input (and (? string?) (? store-path?) file))
      `(,input . ,file))))

  (expression->derivation-in-linux-vm
   store "qemu-image"
   `(let ()
      (use-modules (ice-9 rdelim)
                   (srfi srfi-1)
                   (guix build utils)
                   (guix build linux-initrd))

      (let ((parted  (string-append (assoc-ref %build-inputs "parted")
                                    "/sbin/parted"))
            (mkfs    (string-append (assoc-ref %build-inputs "e2fsprogs")
                                    "/sbin/mkfs.ext3"))
            (grub    (string-append (assoc-ref %build-inputs "grub")
                                    "/sbin/grub-install"))
            (umount  (string-append (assoc-ref %build-inputs "util-linux")
                                    "/bin/umount")) ; XXX: add to Guile
            (initrd  (string-append (assoc-ref %build-inputs "initrd")
                                    "/initrd"))
            (linux   (string-append (assoc-ref %build-inputs "linux")
                                    "/bzImage")))

        (define (read-reference-graph port)
          ;; Return a list of store paths from the reference graph at PORT.
          ;; The data at PORT is the format produced by #:references-graphs.
          (let loop ((line   (read-line port))
                     (result '()))
            (cond ((eof-object? line)
                   (delete-duplicates result))
                  ((string-prefix? "/" line)
                   (loop (read-line port)
                         (cons line result)))
                  (else
                   (loop (read-line port)
                         result)))))

        (define (things-to-copy)
          ;; Return the list of store files to copy to the image.
          (define (graph-from-file file)
            (call-with-input-file file
              read-reference-graph))

          ,(match inputs-to-copy
             (((graph-files . _) ...)
              `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
                                          graph-files))
                      (paths       (append-map graph-from-file graph-files)))
                 (delete-duplicates paths)))
             (#f ''())))

        ;; GRUB is full of shell scripts.
        (setenv "PATH"
                (string-append (dirname grub) ":"
                               (assoc-ref %build-inputs "coreutils") "/bin:"
                               (assoc-ref %build-inputs "findutils") "/bin:"
                               (assoc-ref %build-inputs "sed") "/bin:"
                               (assoc-ref %build-inputs "grep") "/bin:"
                               (assoc-ref %build-inputs "gawk") "/bin"))

        (display "creating partition table...\n")
        (and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
                             "mkpart" "primary" "ext2" "1MiB"
                             ,(format #f "~aB"
                                      (- disk-image-size
                                         (* 5 (expt 2 20))))))
             (begin
               (display "creating ext3 partition...\n")
               (and (zero? (system* mkfs "-F" "/dev/vda1"))
                    (begin
                      (display "mounting partition...\n")
                      (mkdir "/fs")
                      (mount "/dev/vda1" "/fs" "ext3")
                      (mkdir-p "/fs/boot/grub")
                      (copy-file linux "/fs/boot/bzImage")
                      (copy-file initrd "/fs/boot/initrd")

                      ;; Populate the image's store.
                      (mkdir-p (string-append "/fs" ,%store-directory))
                      (for-each (lambda (thing)
                                  (copy-recursively thing
                                                    (string-append "/fs"
                                                                   thing)))
                                (things-to-copy))

                      ;; Populate /dev.
                      (make-essential-device-nodes #:root "/fs")

                      (call-with-output-file "/fs/boot/grub/grub.cfg"
                        (lambda (p)
                          (format p "
set default=1
set timeout=5
search.file /boot/bzImage

menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
  linux /boot/bzImage ~a
  initrd /boot/initrd
}"
                                  ,(string-join linux-arguments))))
                      (and (zero?
                            (system* grub "--no-floppy"
                                     "--boot-directory" "/fs/boot"
                                     "/dev/vda"))
                           (zero?
                            (system* umount "/fs"))
                           (reboot))))))))
   #:system system
   #:inputs `(("parted" ,parted)
              ("grub" ,grub)
              ("e2fsprogs" ,e2fsprogs)
              ("linux" ,linux-libre)
              ("initrd" ,initrd)

              ;; For shell scripts.
              ("sed" ,(car (assoc-ref %final-inputs "sed")))
              ("grep" ,(car (assoc-ref %final-inputs "grep")))
              ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
              ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
              ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
              ("util-linux" ,util-linux)

              ,@inputs-to-copy)
   #:make-disk-image? #t
   #:disk-image-size disk-image-size
   #:references-graphs (map input->name+derivation inputs-to-copy)
   #:modules '((guix build utils)
               (guix build linux-initrd))))

\f
;;;
;;; Guile 2.0 potluck examples.
;;;

(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 (example2)
  (let ((store #f))
    (dynamic-wind
      (lambda ()
        (set! store (open-connection)))
      (lambda ()
        (parameterize ((%guile-for-build (package-derivation store guile-final)))
          (let* ((out   (derivation-path->output-path
                         (package-derivation store mingetty)))
                 (getty (string-append out "/sbin/mingetty"))
                 (boot  (add-text-to-store store "boot"
                                           (object->string
                                            `(begin
                                               ;; Become the session leader,
                                               ;; so that mingetty can do
                                               ;; 'TIOCSCTTY'.
                                               (setsid)

                                               ;; Directly into mingetty.
                                               (execl ,getty "mingetty"
                                                      "--noclear" "tty1")))
                                           (list out))))
           (qemu-image store
                       #:initrd gnu-system-initrd
                       #:linux-arguments `("--root=/dev/vda1"
                                           ,(string-append "--load=" boot))
                       #:disk-image-size (* 400 (expt 2 20))
                       #:inputs-to-copy `(("boot" ,boot)
                                          ("coreutils" ,coreutils)
                                          ("bash" ,bash)
                                          ("guile" ,guile-2.0)
                                          ("mingetty" ,mingetty))))))
      (lambda ()
        (close-connection store)))))

;;; vm.scm ends here
Commit	Line	Data
04086015 LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (gnu system vm)
93d44bd8	20	#:use-module (guix config)
04086015 LC	21	#:use-module (guix store)
	22	#:use-module (guix derivations)
	23	#:use-module (guix packages)
1b89a66e LC	24	#:use-module ((gnu packages base) #:select (%final-inputs
	25	guile-final
	26	coreutils))
	27	#:use-module (gnu packages guile)
	28	#:use-module (gnu packages bash)
04086015 LC	29	#:use-module (gnu packages qemu)
	30	#:use-module (gnu packages parted)
	31	#:use-module (gnu packages grub)
	32	#:use-module (gnu packages linux)
	33	#:use-module (gnu packages linux-initrd)
	34	#:use-module ((gnu packages make-bootstrap)
	35	#:select (%guile-static-stripped))
93d44bd8	36	#:use-module ((gnu packages system)
1b89a66e	37	#:select (mingetty))
ca85d7bc	38	#:use-module (srfi srfi-1)
04086015 LC	39	#:use-module (srfi srfi-26)
	40	#:use-module (ice-9 match)
	41	#:export (expression->derivation-in-linux-vm
	42	qemu-image))
	43
	44	\f
	45	;;; Commentary:
	46	;;;
	47	;;; Tools to evaluate build expressions within virtual machines.
	48	;;;
	49	;;; Code:
	50
2455085a	51	(define* (expression->derivation-in-linux-vm store name exp
04086015	52	#:key
2455085a LC	53	(system (%current-system))
2455085a LC	54	(inputs '())
04086015 LC	55	(linux linux-libre)
04086015 LC	56	(initrd qemu-initrd)
50731c51	57	(qemu qemu/smb-shares)
04086015 LC	58	(env-vars '())
	59	(modules '())
	60	(guile-for-build
	61	(%guile-for-build))
	62
	63	(make-disk-image? #f)
ca85d7bc	64	(references-graphs #f)
04086015 LC	65	(disk-image-size
	66	(* 100 (expt 2 20))))
	67	"Evaluate EXP in a QEMU virtual machine running LINUX with INITRD. In the
	68	virtual machine, EXP has access to all of INPUTS from the store; it should put
	69	its output files in the `/xchg' directory, which is copied to the derivation's
	70	output when the VM terminates.
	71
	72	When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
ca85d7bc LC	73	DISK-IMAGE-SIZE bytes and return it.
	74
	75	When REFERENCES-GRAPHS is true, it must be a list of file name/store path
	76	pairs, as for `derivation'. The files containing the reference graphs are
	77	made available under the /xchg CIFS share."
04086015 LC	78	(define input-alist
04086015 LC	79	(map (match-lambda
4c0f0673	80	((input (? package? package))
04086015	81	`(,input . ,(package-output store package "out" system)))
4c0f0673 LC	82	((input (? package? package) sub-drv)
	83	`(,input . ,(package-output store package sub-drv system)))
	84	((input (and (? string?) (? store-path?) file))
	85	`(,input . ,file)))
04086015 LC	86	inputs))
	87
	88	(define exp*
	89	;; EXP, but with INPUTS available.
	90	`(let ((%build-inputs ',input-alist))
	91	,exp))
	92
	93	(define builder
	94	;; Code that launches the VM that evaluates EXP.
ca85d7bc LC	95	`(let ()
	96	(use-modules (guix build utils)
	97	(srfi srfi-1)
	98	(ice-9 rdelim))
04086015 LC	99
	100	(let ((out (assoc-ref %outputs "out"))
	101	(cu (string-append (assoc-ref %build-inputs "coreutils")
	102	"/bin"))
	103	(qemu (string-append (assoc-ref %build-inputs "qemu")
	104	"/bin/qemu-system-"
	105	(car (string-split ,system #\-))))
	106	(img (string-append (assoc-ref %build-inputs "qemu")
	107	"/bin/qemu-img"))
	108	(linux (string-append (assoc-ref %build-inputs "linux")
	109	"/bzImage"))
	110	(initrd (string-append (assoc-ref %build-inputs "initrd")
	111	"/initrd"))
	112	(builder (assoc-ref %build-inputs "builder")))
	113
	114	;; XXX: QEMU uses "rm -rf" when it's done to remove the temporary SMB
	115	;; directory, so it really needs `rm' in $PATH.
	116	(setenv "PATH" cu)
	117
	118	,(if make-disk-image?
	119	`(zero? (system* img "create" "image.qcow2"
	120	,(number->string disk-image-size)))
	121	'(begin))
	122
	123	(mkdir "xchg")
ca85d7bc LC	124
	125	;; Copy the reference-graph files under xchg/ so EXP can access it.
	126	(begin
	127	,@(match references-graphs
	128	(((graph-files . _) ...)
	129	(map (lambda (file)
	130	`(copy-file ,file
	131	,(string-append "xchg/" file)))
	132	graph-files))
	133	(#f '())))
	134
04086015 LC	135	(and (zero?
	136	(system* qemu "-nographic" "-no-reboot"
	137	"-net" "nic,model=e1000"
	138	"-net" (string-append "user,smb=" (getcwd))
	139	"-kernel" linux
	140	"-initrd" initrd
	141	"-append" (string-append "console=ttyS0 --load="
	142	builder)
	143	,@(if make-disk-image?
	144	'("-hda" "image.qcow2")
	145	'())))
	146	,(if make-disk-image?
	147	'(copy-file "image.qcow2" ; XXX: who mkdir'd OUT?
	148	out)
	149	'(begin
	150	(mkdir out)
	151	(copy-recursively "xchg" out)))))))
	152
	153	(let ((user-builder (add-text-to-store store "builder-in-linux-vm"
	154	(object->string exp*)
	155	'()))
	156	(->drv (cut package-derivation store <> system))
	157	(coreutils (car (assoc-ref %final-inputs "coreutils"))))
	158	(build-expression->derivation store name system builder
	159	`(("qemu" ,(->drv qemu))
	160	("linux" ,(->drv linux))
	161	("initrd" ,(->drv initrd))
	162	("coreutils" ,(->drv coreutils))
	163	("builder" ,user-builder)
	164	,@(map (match-lambda
4c0f0673 LC	165	((name (? package? package)
4c0f0673 LC	166	sub-drv ...)
04086015	167	`(,name ,(->drv package)
4c0f0673 LC	168	,@sub-drv))
	169	((name (? string? file))
	170	`(,name ,file)))
04086015 LC	171	inputs))
04086015 LC	172	#:env-vars env-vars
ca85d7bc LC	173	#:modules (delete-duplicates
	174	`((guix build utils)
	175	,@modules))
	176	#:guile-for-build guile-for-build
	177	#:references-graphs references-graphs)))
04086015 LC	178
	179	(define* (qemu-image store #:key
	180	(name "qemu-image")
	181	(system (%current-system))
	182	(disk-image-size (* 100 (expt 2 20)))
	183	(linux linux-libre)
1b89a66e	184	(linux-arguments '())
04086015	185	(initrd qemu-initrd)
93d44bd8 LC	186	(inputs '())
	187	(inputs-to-copy '())
	188	(boot-expression #f))
1b89a66e LC	189	"Return a bootable, stand-alone QEMU image. The returned image is a full
	190	disk image, with a GRUB installation whose default entry boots LINUX, with the
	191	arguments LINUX-ARGUMENTS, and using INITRD as its initial RAM disk.
93d44bd8 LC	192
	193	INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
	194	into the image being built.
	195
	196	When BOOT-EXPRESSION is true, it is an expression to evaluate when the basic
	197	initialization is done. A typical example is `(execl ...)' to launch the init
	198	process."
	199	(define input->name+derivation
	200	(match-lambda
	201	((name (? package? package))
	202	`(,name . ,(derivation-path->output-path
	203	(package-derivation store package system))))
	204	((name (? package? package) sub-drv)
	205	`(,name . ,(derivation-path->output-path
	206	(package-derivation store package system)
1b89a66e LC	207	sub-drv)))
	208	((input (and (? string?) (? store-path?) file))
	209	`(,input . ,file))))
93d44bd8	210
04086015	211	(expression->derivation-in-linux-vm
2455085a	212	store "qemu-image"
93d44bd8 LC	213	`(let ()
	214	(use-modules (ice-9 rdelim)
	215	(srfi srfi-1)
7c1d8146 LC	216	(guix build utils)
7c1d8146 LC	217	(guix build linux-initrd))
93d44bd8 LC	218
	219	(let ((parted (string-append (assoc-ref %build-inputs "parted")
	220	"/sbin/parted"))
	221	(mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
	222	"/sbin/mkfs.ext3"))
	223	(grub (string-append (assoc-ref %build-inputs "grub")
	224	"/sbin/grub-install"))
	225	(umount (string-append (assoc-ref %build-inputs "util-linux")
	226	"/bin/umount")) ; XXX: add to Guile
	227	(initrd (string-append (assoc-ref %build-inputs "initrd")
	228	"/initrd"))
	229	(linux (string-append (assoc-ref %build-inputs "linux")
7c1d8146	230	"/bzImage")))
93d44bd8 LC	231
	232	(define (read-reference-graph port)
	233	;; Return a list of store paths from the reference graph at PORT.
	234	;; The data at PORT is the format produced by #:references-graphs.
	235	(let loop ((line (read-line port))
	236	(result '()))
	237	(cond ((eof-object? line)
	238	(delete-duplicates result))
	239	((string-prefix? "/" line)
	240	(loop (read-line port)
	241	(cons line result)))
	242	(else
	243	(loop (read-line port)
	244	result)))))
	245
	246	(define (things-to-copy)
	247	;; Return the list of store files to copy to the image.
	248	(define (graph-from-file file)
	249	(call-with-input-file file
	250	read-reference-graph))
	251
	252	,(match inputs-to-copy
	253	(((graph-files . _) ...)
	254	`(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
	255	graph-files))
	256	(paths (append-map graph-from-file graph-files)))
	257	(delete-duplicates paths)))
	258	(#f ''())))
	259
	260	;; GRUB is full of shell scripts.
	261	(setenv "PATH"
	262	(string-append (dirname grub) ":"
	263	(assoc-ref %build-inputs "coreutils") "/bin:"
	264	(assoc-ref %build-inputs "findutils") "/bin:"
	265	(assoc-ref %build-inputs "sed") "/bin:"
	266	(assoc-ref %build-inputs "grep") "/bin:"
	267	(assoc-ref %build-inputs "gawk") "/bin"))
	268
	269	(display "creating partition table...\n")
93d44bd8 LC	270	(and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
	271	"mkpart" "primary" "ext2" "1MiB"
	272	,(format #f "~aB"
	273	(- disk-image-size
	274	(* 5 (expt 2 20))))))
	275	(begin
	276	(display "creating ext3 partition...\n")
93d44bd8 LC	277	(and (zero? (system* mkfs "-F" "/dev/vda1"))
	278	(begin
	279	(display "mounting partition...\n")
	280	(mkdir "/fs")
	281	(mount "/dev/vda1" "/fs" "ext3")
	282	(mkdir-p "/fs/boot/grub")
	283	(copy-file linux "/fs/boot/bzImage")
	284	(copy-file initrd "/fs/boot/initrd")
	285
	286	;; Populate the image's store.
	287	(mkdir-p (string-append "/fs" ,%store-directory))
	288	(for-each (lambda (thing)
	289	(copy-recursively thing
	290	(string-append "/fs"
	291	thing)))
	292	(things-to-copy))
	293
7c1d8146 LC	294	;; Populate /dev.
	295	(make-essential-device-nodes #:root "/fs")
	296
93d44bd8 LC	297	(call-with-output-file "/fs/boot/grub/grub.cfg"
	298	(lambda (p)
	299	(format p "
baed8816 LC	300	set default=1
baed8816 LC	301	set timeout=5
04086015 LC	302	search.file /boot/bzImage
04086015 LC	303
baed8816	304	menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
1b89a66e	305	linux /boot/bzImage ~a
04086015	306	initrd /boot/initrd
93d44bd8	307	}"
1b89a66e	308	,(string-join linux-arguments))))
93d44bd8 LC	309	(and (zero?
	310	(system* grub "--no-floppy"
	311	"--boot-directory" "/fs/boot"
	312	"/dev/vda"))
	313	(zero?
	314	(system* umount "/fs"))
	315	(reboot))))))))
2455085a LC	316	#:system system
	317	#:inputs `(("parted" ,parted)
	318	("grub" ,grub)
	319	("e2fsprogs" ,e2fsprogs)
	320	("linux" ,linux-libre)
93d44bd8 LC	321	("initrd" ,initrd)
93d44bd8 LC	322
2455085a LC	323	;; For shell scripts.
	324	("sed" ,(car (assoc-ref %final-inputs "sed")))
	325	("grep" ,(car (assoc-ref %final-inputs "grep")))
	326	("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
	327	("findutils" ,(car (assoc-ref %final-inputs "findutils")))
	328	("gawk" ,(car (assoc-ref %final-inputs "gawk")))
93d44bd8 LC	329	("util-linux" ,util-linux)
	330
	331	,@inputs-to-copy)
04086015	332	#:make-disk-image? #t
93d44bd8 LC	333	#:disk-image-size disk-image-size
93d44bd8 LC	334	#:references-graphs (map input->name+derivation inputs-to-copy)
7c1d8146 LC	335	#:modules '((guix build utils)
7c1d8146 LC	336	(guix build linux-initrd))))
04086015 LC	337
	338	\f
	339	;;;
	340	;;; Guile 2.0 potluck examples.
	341	;;;
	342
	343	(define (example1)
	344	(let ((store #f))
	345	(dynamic-wind
	346	(lambda ()
	347	(set! store (open-connection)))
	348	(lambda ()
	349	(parameterize ((%guile-for-build (package-derivation store guile-final)))
	350	(expression->derivation-in-linux-vm
2455085a	351	store "vm-test"
04086015 LC	352	'(begin
	353	(display "hello from boot!\n")
	354	(call-with-output-file "/xchg/hello"
	355	(lambda (p)
2455085a	356	(display "world" p)))))))
04086015 LC	357	(lambda ()
	358	(close-connection store)))))
	359
	360	(define (example2)
	361	(let ((store #f))
	362	(dynamic-wind
	363	(lambda ()
	364	(set! store (open-connection)))
	365	(lambda ()
	366	(parameterize ((%guile-for-build (package-derivation store guile-final)))
1b89a66e LC	367	(let* ((out (derivation-path->output-path
	368	(package-derivation store mingetty)))
	369	(getty (string-append out "/sbin/mingetty"))
	370	(boot (add-text-to-store store "boot"
	371	(object->string
	372	`(begin
	373	;; Become the session leader,
	374	;; so that mingetty can do
	375	;; 'TIOCSCTTY'.
	376	(setsid)
	377
	378	;; Directly into mingetty.
	379	(execl ,getty "mingetty"
	380	"--noclear" "tty1")))
	381	(list out))))
93d44bd8	382	(qemu-image store
1b89a66e LC	383	#:initrd gnu-system-initrd
	384	#:linux-arguments `("--root=/dev/vda1"
	385	,(string-append "--load=" boot))
93d44bd8	386	#:disk-image-size (* 400 (expt 2 20))
1b89a66e LC	387	#:inputs-to-copy `(("boot" ,boot)
	388	("coreutils" ,coreutils)
	389	("bash" ,bash)
	390	("guile" ,guile-2.0)
	391	("mingetty" ,mingetty))))))
04086015 LC	392	(lambda ()
	393	(close-connection store)))))
	394
	395	;;; vm.scm ends here