nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2014-04-27 14:58:15 +02:00
parent eee2127109
commit 1aa0033b64
2 changed files with 93 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gnu/system.scm
View File

@ -52,8 +52,8 @@
operating-system-locale operating-system-locale
operating-system-services operating-system-services
operating-system-profile-directory operating-system-derivation
operating-system-derivation)) operating-system-profile))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -282,17 +282,12 @@ alias ll='ls -l'
("tzdata" ,tzdata)) ("tzdata" ,tzdata))
#:name "etc"))) #:name "etc")))
(define (operating-system-profile-derivation os) (define (operating-system-profile os)
"Return a derivation that builds the default profile of OS." "Return a derivation that builds the default profile of OS."
;; TODO: Replace with a real profile with a manifest. ;; TODO: Replace with a real profile with a manifest.
(union (operating-system-packages os) (union (operating-system-packages os)
#:name "default-profile")) #: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) (define (operating-system-accounts os)
"Return the user accounts for OS, including an obligatory 'root' account." "Return the user accounts for OS, including an obligatory 'root' account."
(mlet %store-monad ((services (sequence %store-monad (mlet %store-monad ((services (sequence %store-monad
@ -317,7 +312,7 @@ alias ll='ls -l'
(cons %pam-other-services (cons %pam-other-services
(append-map service-pam-services services)))) (append-map service-pam-services services))))
(accounts (operating-system-accounts os)) (accounts (operating-system-accounts os))
(profile-drv (operating-system-profile-derivation os)) (profile-drv (operating-system-profile os))
(groups -> (append (operating-system-groups os) (groups -> (append (operating-system-groups os)
(append-map service-user-groups services)))) (append-map service-user-groups services))))
(etc-directory #:accounts accounts #:groups groups (etc-directory #:accounts accounts #:groups groups
@ -341,7 +336,7 @@ we're running in the final root."
(define (operating-system-derivation os) (define (operating-system-derivation os)
"Return a derivation that builds OS." "Return a derivation that builds OS."
(mlet* %store-monad (mlet* %store-monad
((profile-drv (operating-system-profile-derivation os)) ((profile-drv (operating-system-profile os))
(profile -> (derivation->output-path profile-drv)) (profile -> (derivation->output-path profile-drv))
(etc-drv (operating-system-etc-directory os)) (etc-drv (operating-system-etc-directory os))
(etc -> (derivation->output-path etc-drv)) (etc -> (derivation->output-path etc-drv))

206
gnu/system/vm.scm
View File

@ -82,18 +82,14 @@ input tuple. The output file name is when building for SYSTEM."
((input (and (? string?) (? store-path?) file)) ((input (and (? string?) (? store-path?) file))
(return `(,input . ,file)))))) (return `(,input . ,file))))))
;; An alias to circumvent name clashes.
(define %imported-modules imported-modules)
(define* (expression->derivation-in-linux-vm name exp (define* (expression->derivation-in-linux-vm name exp
#:key #:key
(system (%current-system)) (system (%current-system))
(inputs '())
(linux linux-libre) (linux linux-libre)
initrd initrd
(qemu qemu-headless) (qemu qemu-headless)
(env-vars '()) (env-vars '())
(imported-modules (modules
'((guix build vm) '((guix build vm)
(guix build linux-initrd) (guix build linux-initrd)
(guix build utils))) (guix build utils)))
@ -106,7 +102,7 @@ input tuple. The output file name is when building for SYSTEM."
(disk-image-size (disk-image-size
(* 100 (expt 2 20)))) (* 100 (expt 2 20))))
"Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a "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 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 copied to the derivation's output when the VM terminates. The virtual machine
runs with MEMORY-SIZE MiB of memory. runs with MEMORY-SIZE MiB of memory.
@ -114,51 +110,15 @@ runs with MEMORY-SIZE MiB of memory.
When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
DISK-IMAGE-SIZE bytes and return it. DISK-IMAGE-SIZE bytes and return it.
IMPORTED-MODULES is the set of modules imported in the execution environment MODULES is the set of modules imported in the execution environment of EXP.
of EXP.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path 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 pairs, as for `derivation'. The files containing the reference graphs are
made available under the /xchg CIFS share." 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 (mlet* %store-monad
((input-alist (sequence %store-monad input-alist)) ((module-dir (imported-modules modules))
(module-dir (%imported-modules imported-modules)) (compiled (compiled-modules modules))
(compiled (compiled-modules imported-modules)) (user-builder (gexp->file "builder-in-linux-vm" exp))
(exp* -> `(let ((%build-inputs ',input-alist))
,exp))
(user-builder (text-file "builder-in-linux-vm"
(object->string exp*)))
(loader (gexp->file "linux-vm-loader" (loader (gexp->file "linux-vm-loader"
#~(begin #~(begin
(set! %load-path (set! %load-path
@ -172,35 +132,50 @@ made available under the /xchg CIFS share."
(return initrd) (return initrd)
(qemu-initrd #:guile-modules-in-chroot? #t (qemu-initrd #:guile-modules-in-chroot? #t
#:mounts `((9p "store" ,(%store-prefix)) #:mounts `((9p "store" ,(%store-prefix))
(9p "xchg" "/xchg"))))) (9p "xchg" "/xchg"))))))
(inputs (lower-inputs `(("qemu" ,qemu)
("linux" ,linux) (define builder
("initrd" ,initrd) ;; Code that launches the VM that evaluates EXP.
("coreutils" ,coreutils) #~(begin
("builder" ,user-builder) (use-modules (guix build utils)
("loader" ,loader) (guix build vm))
,@inputs))))
(derivation-expression name builder (let ((inputs '#$(list qemu coreutils))
;; TODO: Require the "kvm" feature. (linux (string-append #$linux "/bzImage"))
#:system system (initrd (string-append #$initrd "/initrd"))
#:inputs inputs (loader #$loader)
#:env-vars env-vars (graphs '#$(match references-graphs
#:modules (delete-duplicates (((graph-files . _) ...) graph-files)
`((guix build utils) (_ #f))))
(guix build vm)
(guix build linux-initrd) (set-path-environment-variable "PATH" '("bin") inputs)
,@imported-modules))
#:guile-for-build guile-for-build (load-in-linux-vm loader
#:references-graphs references-graphs))) #: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 (define* (qemu-image #:key
(name "qemu-image") (name "qemu-image")
(system (%current-system)) (system (%current-system))
(qemu qemu-headless)
(disk-image-size (* 100 (expt 2 20))) (disk-image-size (* 100 (expt 2 20)))
grub-configuration grub-configuration
(initialize-store? #f) (initialize-store? #f)
(populate #f) (populate #f)
(inputs '())
(inputs-to-copy '())) (inputs-to-copy '()))
"Return a bootable, stand-alone QEMU image. The returned image is a full "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 disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
@ -218,41 +193,37 @@ such as /etc files."
((graph (sequence %store-monad ((graph (sequence %store-monad
(map input->name+output inputs-to-copy)))) (map input->name+output inputs-to-copy))))
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
"qemu-image" name
`(let () #~(begin
(use-modules (guix build vm) (use-modules (guix build vm)
(guix build utils)) (guix build utils))
(set-path-environment-variable "PATH" '("bin" "sbin") (let ((inputs
(map cdr %build-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) '())))
(let ((graphs ',(match inputs-to-copy ;; This variable is unused but allows us to add INPUTS-TO-COPY
(((names . _) ...) ;; as inputs.
names)))) (to-copy
(initialize-hard-disk #:grub.cfg ,grub-configuration '#$(map (match-lambda
#:closures-to-copy graphs ((name thing) thing)
#:disk-image-size ,disk-image-size ((name thing output) `(,thing ,output)))
#:initialize-store? ,initialize-store? inputs-to-copy)))
#:directives ',populate)
(reboot))) (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 #: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 #:make-disk-image? #t
#:disk-image-size disk-image-size #:disk-image-size disk-image-size
#:references-graphs graph))) #:references-graphs graph)))
@ -283,29 +254,28 @@ basic contents of the root file system of OS."
(gid (or (user-account-gid user) 0)) (gid (or (user-account-gid user) 0))
(root (string-append "/var/guix/profiles/per-user/" (root (string-append "/var/guix/profiles/per-user/"
(user-account-name user)))) (user-account-name user))))
`((directory ,root ,uid ,gid) #~((directory #$root #$uid #$gid)
(directory ,home ,uid ,gid)))) (directory #$home #$uid #$gid))))
(mlet* %store-monad ((os-drv (operating-system-derivation os)) (mlet* %store-monad ((os-drv (operating-system-derivation os))
(os-dir -> (derivation->output-path os-drv))
(build-gid (operating-system-build-gid os)) (build-gid (operating-system-build-gid os))
(profile (operating-system-profile-directory os))) (profile (operating-system-profile os)))
(return `((directory ,(%store-prefix) 0 ,(or build-gid 0)) (return #~((directory #$(%store-prefix) 0 #$(or build-gid 0))
(directory "/etc") (directory "/etc")
(directory "/var/log") ; for dmd (directory "/var/log") ; for dmd
(directory "/var/run/nscd") (directory "/var/run/nscd")
(directory "/var/guix/gcroots") (directory "/var/guix/gcroots")
("/var/guix/gcroots/system" -> ,os-dir) ("/var/guix/gcroots/system" -> #$os-drv)
(directory "/run") (directory "/run")
("/run/current-system" -> ,profile) ("/run/current-system" -> #$profile)
(directory "/bin") (directory "/bin")
("/bin/sh" -> "/run/current-system/bin/bash") ("/bin/sh" -> "/run/current-system/bin/bash")
(directory "/tmp") (directory "/tmp")
(directory "/var/guix/profiles/per-user/root" 0 0) (directory "/var/guix/profiles/per-user/root" 0 0)
(directory "/root" 0 0) ; an exception (directory "/root" 0 0) ; an exception
,@(append-map user-directories #$@(append-map user-directories
(operating-system-users os)))))) (operating-system-users os))))))
(define* (system-qemu-image os (define* (system-qemu-image os
#:key (disk-image-size (* 900 (expt 2 20)))) #:key (disk-image-size (* 900 (expt 2 20))))