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:
parent
4106c58988
commit
1eeccc2f31
|
@ -292,12 +292,23 @@ (define* (system-qemu-image os
|
||||||
(disk-image-size (* 900 (expt 2 20))))
|
(disk-image-size (* 900 (expt 2 20))))
|
||||||
"Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
|
"Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes
|
||||||
of the GNU system as described by OS."
|
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)
|
(let ((os (operating-system (inherit os)
|
||||||
;; The mounted file systems are under our control.
|
;; Force our own root file system.
|
||||||
(file-systems (list (file-system
|
(file-systems (cons (file-system
|
||||||
(mount-point "/")
|
(mount-point "/")
|
||||||
(device "/dev/sda1")
|
(device "/dev/sda1")
|
||||||
(type file-system-type)))))))
|
(type file-system-type))
|
||||||
|
file-systems-to-keep)))))
|
||||||
(mlet* %store-monad
|
(mlet* %store-monad
|
||||||
((os-drv (operating-system-derivation os))
|
((os-drv (operating-system-derivation os))
|
||||||
(os-dir -> (derivation->output-path os-drv))
|
(os-dir -> (derivation->output-path os-drv))
|
||||||
|
@ -315,17 +326,27 @@ (define (virtualized-operating-system os)
|
||||||
environment with the store shared with the host."
|
environment with the store shared with the host."
|
||||||
(operating-system (inherit os)
|
(operating-system (inherit os)
|
||||||
(initrd (cut qemu-initrd <> #:volatile-root? #t))
|
(initrd (cut qemu-initrd <> #:volatile-root? #t))
|
||||||
(file-systems (list (file-system
|
(file-systems (cons* (file-system
|
||||||
(mount-point "/")
|
(mount-point "/")
|
||||||
(device "/dev/vda1")
|
(device "/dev/vda1")
|
||||||
(type "ext4"))
|
(type "ext4"))
|
||||||
(file-system
|
(file-system
|
||||||
(mount-point (%store-prefix))
|
(mount-point (%store-prefix))
|
||||||
(device "store")
|
(device "store")
|
||||||
(type "9p")
|
(type "9p")
|
||||||
(needed-for-boot? #t)
|
(needed-for-boot? #t)
|
||||||
(options "trans=virtio")
|
(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
|
(define* (system-qemu-image/shared-store
|
||||||
os
|
os
|
||||||
|
|
Loading…
Reference in a new issue