Skip to content
Snippets Groups Projects
Commit 1aa0033b authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

vm: Rewrite support procedures to use gexps. 

* gnu/system/vm.scm (%imported-modules): Remove.
  (expression->derivation-in-linux-vm): Remove 'inputs' parameter.
  Rename 'imported-modules' to 'modules'.  Rewrite using gexps and
  'gexp->derivation'.
  (qemu-image): Add 'qemu' parameter.  Pass NAME to
  'expression->derivation-in-linux-vm'.  Rewrite using gexps.  Remove
  #:inputs argument to 'expression->derivation-in-linux-vm'.
  (operating-system-default-contents): Rewrite using gexps.
* gnu/system.scm (operating-system-profile-derivation): Rename to...
  (operating-system-profile): ... this.  Adjust callers.
  (operating-system-profile-directory): Remove.
parent eee21271
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
gnu/system.scm
+ 5
− 10
View file @ 1aa0033b
......@@ -52,8 +52,8 @@ (define-module (gnu system)
operating-system-locale
operating-system-services
operating-system-profile-directory
operating-system-derivation))
operating-system-derivation
operating-system-profile))
;;; Commentary:
;;;
......@@ -282,17 +282,12 @@ (define* (etc-directory #:key
("tzdata" ,tzdata))
#:name "etc")))
(define (operating-system-profile-derivation os)
(define (operating-system-profile os)
"Return a derivation that builds the default profile of OS."
;; TODO: Replace with a real profile with a manifest.
(union (operating-system-packages os)
#:name "default-profile"))
(define (operating-system-profile-directory os)
"Return the directory name of the default profile of OS."
(mlet %store-monad ((drv (operating-system-profile-derivation os)))
(return (derivation->output-path drv))))
(define (operating-system-accounts os)
"Return the user accounts for OS, including an obligatory 'root' account."
(mlet %store-monad ((services (sequence %store-monad
......@@ -317,7 +312,7 @@ (define (operating-system-etc-directory os)
(cons %pam-other-services
(append-map service-pam-services services))))
(accounts (operating-system-accounts os))
(profile-drv (operating-system-profile-derivation os))
(profile-drv (operating-system-profile os))
(groups -> (append (operating-system-groups os)
(append-map service-user-groups services))))
(etc-directory #:accounts accounts #:groups groups
......@@ -341,7 +336,7 @@ (define (operating-system-boot-script os)
(define (operating-system-derivation os)
"Return a derivation that builds OS."
(mlet* %store-monad
((profile-drv (operating-system-profile-derivation os))
((profile-drv (operating-system-profile os))
(profile -> (derivation->output-path profile-drv))
(etc-drv (operating-system-etc-directory os))
(etc -> (derivation->output-path etc-drv))
......
gnu/system/vm.scm
+ 91
− 121
View file @ 1aa0033b
......@@ -82,18 +82,14 @@ (define* (input->name+output tuple #:key (system (%current-system)))
((input (and (? string?) (? store-path?) file))
(return `(,input . ,file))))))
;; An alias to circumvent name clashes.
(define %imported-modules imported-modules)
(define* (expression->derivation-in-linux-vm name exp
#:key
(system (%current-system))
(inputs '())
(linux linux-libre)
initrd
(qemu qemu-headless)
(env-vars '())
(imported-modules
(modules
'((guix build vm)
(guix build linux-initrd)
(guix build utils)))
......@@ -106,7 +102,7 @@ (define* (expression->derivation-in-linux-vm name exp
(disk-image-size
(* 100 (expt 2 20))))
"Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
derivation). In the virtual machine, EXP has access to all of INPUTS from the
derivation). In the virtual machine, EXP has access to all its 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. The virtual machine
runs with MEMORY-SIZE MiB of memory.
......@@ -114,51 +110,15 @@ (define* (expression->derivation-in-linux-vm name exp
When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
DISK-IMAGE-SIZE bytes and return it.
IMPORTED-MODULES is the set of modules imported in the execution environment
of EXP.
MODULES is the set of modules imported in the execution environment of EXP.
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."
;; FIXME: Add #:modules parameter, for the 'use-modules' form.
(define input-alist
(map input->name+output inputs))
(define builder
;; Code that launches the VM that evaluates EXP.
`(let ()
(use-modules (guix build utils)
(guix build vm))
(let ((linux (string-append (assoc-ref %build-inputs "linux")
"/bzImage"))
(initrd (string-append (assoc-ref %build-inputs "initrd")
"/initrd"))
(loader (assoc-ref %build-inputs "loader"))
(graphs ',(match references-graphs
(((graph-files . _) ...) graph-files)
(_ #f))))
(set-path-environment-variable "PATH" '("bin")
(map cdr %build-inputs))
(load-in-linux-vm loader
#:output (assoc-ref %outputs "out")
#:linux linux #:initrd initrd
#:memory-size ,memory-size
#:make-disk-image? ,make-disk-image?
#:disk-image-size ,disk-image-size
#:references-graphs graphs))))
(mlet* %store-monad
((input-alist (sequence %store-monad input-alist))
(module-dir (%imported-modules imported-modules))
(compiled (compiled-modules imported-modules))
(exp* -> `(let ((%build-inputs ',input-alist))
,exp))
(user-builder (text-file "builder-in-linux-vm"
(object->string exp*)))
((module-dir (imported-modules modules))
(compiled (compiled-modules modules))
(user-builder (gexp->file "builder-in-linux-vm" exp))
(loader (gexp->file "linux-vm-loader"
#~(begin
(set! %load-path
......@@ -172,35 +132,50 @@ (define builder
(return initrd)
(qemu-initrd #:guile-modules-in-chroot? #t
#:mounts `((9p "store" ,(%store-prefix))
(9p "xchg" "/xchg")))))
(inputs (lower-inputs `(("qemu" ,qemu)
("linux" ,linux)
("initrd" ,initrd)
("coreutils" ,coreutils)
("builder" ,user-builder)
("loader" ,loader)
,@inputs))))
(derivation-expression name builder
;; TODO: Require the "kvm" feature.
#:system system
#:inputs inputs
#:env-vars env-vars
#:modules (delete-duplicates
`((guix build utils)
(guix build vm)
(guix build linux-initrd)
,@imported-modules))
#:guile-for-build guile-for-build
#:references-graphs references-graphs)))
(9p "xchg" "/xchg"))))))
(define builder
;; Code that launches the VM that evaluates EXP.
#~(begin
(use-modules (guix build utils)
(guix build vm))
(let ((inputs '#$(list qemu coreutils))
(linux (string-append #$linux "/bzImage"))
(initrd (string-append #$initrd "/initrd"))
(loader #$loader)
(graphs '#$(match references-graphs
(((graph-files . _) ...) graph-files)
(_ #f))))
(set-path-environment-variable "PATH" '("bin") inputs)
(load-in-linux-vm loader
#:output #$output
#:linux linux #:initrd initrd
#:memory-size #$memory-size
#:make-disk-image? #$make-disk-image?
#:disk-image-size #$disk-image-size
#:references-graphs graphs))))
(gexp->derivation name builder
;; TODO: Require the "kvm" feature.
#:system system
#:env-vars env-vars
#:modules `((guix build utils)
(guix build vm)
(guix build linux-initrd))
#:guile-for-build guile-for-build
#:references-graphs references-graphs)))
(define* (qemu-image #:key
(name "qemu-image")
(system (%current-system))
(qemu qemu-headless)
(disk-image-size (* 100 (expt 2 20)))
grub-configuration
(initialize-store? #f)
(populate #f)
(inputs '())
(inputs-to-copy '()))
"Return a bootable, stand-alone QEMU image. The returned image is a full
disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
......@@ -218,41 +193,37 @@ (define* (qemu-image #:key
((graph (sequence %store-monad
(map input->name+output inputs-to-copy))))
(expression->derivation-in-linux-vm
"qemu-image"
`(let ()
(use-modules (guix build vm)
(guix build utils))
(set-path-environment-variable "PATH" '("bin" "sbin")
(map cdr %build-inputs))
(let ((graphs ',(match inputs-to-copy
(((names . _) ...)
names))))
(initialize-hard-disk #:grub.cfg ,grub-configuration
#:closures-to-copy graphs
#:disk-image-size ,disk-image-size
#:initialize-store? ,initialize-store?
#:directives ',populate)
(reboot)))
name
#~(begin
(use-modules (guix build vm)
(guix build utils))
(let ((inputs
'#$(append (list qemu parted grub e2fsprogs util-linux)
(map (compose car (cut assoc-ref %final-inputs <>))
'("sed" "grep" "coreutils" "findutils" "gawk"))
(if initialize-store? (list guix) '())))
;; This variable is unused but allows us to add INPUTS-TO-COPY
;; as inputs.
(to-copy
'#$(map (match-lambda
((name thing) thing)
((name thing output) `(,thing ,output)))
inputs-to-copy)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(let ((graphs '#$(match inputs-to-copy
(((names . _) ...)
names))))
(initialize-hard-disk #:grub.cfg #$grub-configuration
#:closures-to-copy graphs
#:disk-image-size #$disk-image-size
#:initialize-store? #$initialize-store?
#:directives '#$populate)
(reboot))))
#:system system
#:inputs `(("parted" ,parted)
("grub" ,grub)
("e2fsprogs" ,e2fsprogs)
;; 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)
,@(if initialize-store?
`(("guix" ,guix))
'())
,@inputs-to-copy)
#:make-disk-image? #t
#:disk-image-size disk-image-size
#:references-graphs graph)))
......@@ -283,29 +254,28 @@ (define (user-directories user)
(gid (or (user-account-gid user) 0))
(root (string-append "/var/guix/profiles/per-user/"
(user-account-name user))))
`((directory ,root ,uid ,gid)
(directory ,home ,uid ,gid))))
#~((directory #$root #$uid #$gid)
(directory #$home #$uid #$gid))))
(mlet* %store-monad ((os-drv (operating-system-derivation os))
(os-dir -> (derivation->output-path os-drv))
(build-gid (operating-system-build-gid os))
(profile (operating-system-profile-directory os)))
(return `((directory ,(%store-prefix) 0 ,(or build-gid 0))
(directory "/etc")
(directory "/var/log") ; for dmd
(directory "/var/run/nscd")
(directory "/var/guix/gcroots")
("/var/guix/gcroots/system" -> ,os-dir)
(directory "/run")
("/run/current-system" -> ,profile)
(directory "/bin")
("/bin/sh" -> "/run/current-system/bin/bash")
(directory "/tmp")
(directory "/var/guix/profiles/per-user/root" 0 0)
(directory "/root" 0 0) ; an exception
,@(append-map user-directories
(operating-system-users os))))))
(profile (operating-system-profile os)))
(return #~((directory #$(%store-prefix) 0 #$(or build-gid 0))
(directory "/etc")
(directory "/var/log") ; for dmd
(directory "/var/run/nscd")
(directory "/var/guix/gcroots")
("/var/guix/gcroots/system" -> #$os-drv)
(directory "/run")
("/run/current-system" -> #$profile)
(directory "/bin")
("/bin/sh" -> "/run/current-system/bin/bash")
(directory "/tmp")
(directory "/var/guix/profiles/per-user/root" 0 0)
(directory "/root" 0 0) ; an exception
#$@(append-map user-directories
(operating-system-users os))))))
(define* (system-qemu-image os
#:key (disk-image-size (* 900 (expt 2 20))))
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment