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

vm: Keep acceptable file systems from the original OS. 

* gnu/system/vm.scm (virtualized-operating-system): Instead of
  completely overriding 'file-systems', use 'remove' to filter out some
  of those declared in OS.
  (system-qemu-image): Likewise.
This commit is contained in:
Ludovic Courtès 2014-05-14 23:15:51 +02:00
parent 4106c58988
commit 1eeccc2f31
1 changed files with 35 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gnu/system/vm.scm
View File

@ -292,12 +292,23 @@ basic contents of the root file system of OS."
(disk-image-size (* 900 (expt 2 20))))
"Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
of the GNU system as described by OS."
(define file-systems-to-keep
;; Keep only file systems other than root and not normally bound to real
;; devices.
(remove (lambda (fs)
(let ((target (file-system-mount-point fs))
(source (file-system-device fs)))
(or (string=? target "/")
(string-prefix? "/dev/" source))))
(operating-system-file-systems os)))
(let ((os (operating-system (inherit os)
;; The mounted file systems are under our control.
(file-systems (list (file-system
;; Force our own root file system.
(file-systems (cons (file-system
(mount-point "/")
(device "/dev/sda1")
(type file-system-type)))))))
(type file-system-type))
file-systems-to-keep)))))
(mlet* %store-monad
((os-drv (operating-system-derivation os))
(os-dir -> (derivation->output-path os-drv))
@ -315,7 +326,7 @@ of the GNU system as described by OS."
environment with the store shared with the host."
(operating-system (inherit os)
(initrd (cut qemu-initrd <> #:volatile-root? #t))
(file-systems (list (file-system
(file-systems (cons* (file-system
(mount-point "/")
(device "/dev/vda1")
(type "ext4"))
@ -325,7 +336,17 @@ environment with the store shared with the host."
(type "9p")
(needed-for-boot? #t)
(options "trans=virtio")
(check? #f))))))
(check? #f))
;; Remove file systems that conflict with those
;; above, or that are normally bound to real devices.
(remove (lambda (fs)
(let ((target (file-system-mount-point fs))
(source (file-system-device fs)))
(or (string=? target (%store-prefix))
(string=? target "/")
(string-prefix? "/dev/" source))))
(operating-system-file-systems os))))))
(define* (system-qemu-image/shared-store
os