diff options
| -rw-r--r-- | gnu/services.scm | 94 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 122 |
2 files changed, 97 insertions, 119 deletions
diff --git a/gnu/services.scm b/gnu/services.scm index 661835f68e..5479bfae19 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -238,42 +238,33 @@ directory." (define (cleanup-gexp _) "Return as a monadic value a gexp to clean up /tmp and similar places upon boot." - (define %modules - '((guix build utils))) - - (mlet %store-monad ((modules (imported-modules %modules)) - (compiled (compiled-modules %modules))) - (return #~(begin - (eval-when (expand load eval) - ;; Make sure 'use-modules' below succeeds. - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - - (use-modules (guix build utils)) - - ;; Clean out /tmp and /var/run. - ;; - ;; XXX This needs to happen before service activations, so it - ;; has to be here, but this also implicitly assumes that /tmp - ;; and /var/run are on the root partition. - (letrec-syntax ((fail-safe (syntax-rules () - ((_ exp rest ...) - (begin - (catch 'system-error - (lambda () exp) - (const #f)) - (fail-safe rest ...))) - ((_) - #t)))) - ;; Ignore I/O errors so the system can boot. - (fail-safe - (delete-file-recursively "/tmp") - (delete-file-recursively "/var/run") - (mkdir "/tmp") - (chmod "/tmp" #o1777) - (mkdir "/var/run") - (chmod "/var/run" #o755))))))) + (with-monad %store-monad + (with-imported-modules '((guix build utils)) + (return #~(begin + (use-modules (guix build utils)) + + ;; Clean out /tmp and /var/run. + ;; + ;; XXX This needs to happen before service activations, so it + ;; has to be here, but this also implicitly assumes that /tmp + ;; and /var/run are on the root partition. + (letrec-syntax ((fail-safe (syntax-rules () + ((_ exp rest ...) + (begin + (catch 'system-error + (lambda () exp) + (const #f)) + (fail-safe rest ...))) + ((_) + #t)))) + ;; Ignore I/O errors so the system can boot. + (fail-safe + (delete-file-recursively "/tmp") + (delete-file-recursively "/var/run") + (mkdir "/tmp") + (chmod "/tmp" #o1777) + (mkdir "/var/run") + (chmod "/var/run" #o755)))))))) (define cleanup-service-type ;; Service that cleans things up in /tmp and similar. @@ -337,29 +328,22 @@ ACTIVATION-SCRIPT-TYPE." (cut gexp->file "activate-service" <>) gexps)) - (mlet* %store-monad ((actions (service-activations)) - (modules (imported-modules %modules)) - (compiled (compiled-modules %modules))) + (mlet* %store-monad ((actions (service-activations))) (gexp->file "activate" - #~(begin - (eval-when (expand load eval) - ;; Make sure 'use-modules' below succeeds. - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - - (use-modules (gnu build activation)) + (with-imported-modules %modules + #~(begin + (use-modules (gnu build activation)) - ;; Make sure /bin/sh is valid and current. - (activate-/bin/sh - (string-append #$(canonical-package bash) "/bin/sh")) + ;; Make sure /bin/sh is valid and current. + (activate-/bin/sh + (string-append #$(canonical-package bash) "/bin/sh")) - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions) + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions) - ;; Set up /run/current-system. - (activate-current-system))))) + ;; Set up /run/current-system. + (activate-current-system)))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index fc5eaf5706..c31e3a80ef 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -90,6 +90,21 @@ (options "trans=virtio") (check? #f)))) +(define %vm-module-closure + ;; The closure of (gnu build vm), roughly. + ;; FIXME: Compute it automatically. + '((gnu build vm) + (gnu build install) + (gnu build linux-boot) + (gnu build linux-modules) + (gnu build file-systems) + (guix elf) + (guix records) + (guix build utils) + (guix build syscalls) + (guix build bournish) + (guix build store-copy))) + (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) @@ -97,18 +112,6 @@ initrd (qemu qemu-minimal) (env-vars '()) - (modules - '((gnu build vm) - (gnu build install) - (gnu build linux-boot) - (gnu build linux-modules) - (gnu build file-systems) - (guix elf) - (guix records) - (guix build utils) - (guix build syscalls) - (guix build bournish) - (guix build store-copy))) (guile-for-build (%guile-for-build)) @@ -128,23 +131,13 @@ When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and return it. -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." (mlet* %store-monad - ((module-dir (imported-modules modules)) - (compiled (compiled-modules modules)) - (user-builder (gexp->file "builder-in-linux-vm" exp)) + ((user-builder (gexp->file "builder-in-linux-vm" exp)) (loader (gexp->file "linux-vm-loader" - #~(begin - (set! %load-path - (cons #$module-dir %load-path)) - (set! %load-compiled-path - (cons #$compiled - %load-compiled-path)) - (primitive-load #$user-builder)))) + #~(primitive-load #$user-builder))) (coreutils -> (canonical-package coreutils)) (initrd (if initrd ; use the default initrd? (return initrd) @@ -155,7 +148,7 @@ made available under the /xchg CIFS share." (define builder ;; Code that launches the VM that evaluates EXP. - (with-imported-modules modules + (with-imported-modules %vm-module-closure #~(begin (use-modules (guix build utils) (gnu build vm)) @@ -212,45 +205,46 @@ register INPUTS in the store database of the image so that Guix can be used in the image." (expression->derivation-in-linux-vm name - #~(begin - (use-modules (gnu build vm) - (guix build utils)) - - (let ((inputs - '#$(append (list qemu parted grub e2fsprogs) - (map canonical-package - (list sed grep coreutils findutils gawk)) - (if register-closures? (list guix) '()))) - - ;; This variable is unused but allows us to add INPUTS-TO-COPY - ;; as inputs. - (to-register - '#$(map (match-lambda - ((name thing) thing) - ((name thing output) `(,thing ,output))) - inputs))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - - (let* ((graphs '#$(match inputs - (((names . _) ...) - names))) - (initialize (root-partition-initializer - #:closures graphs - #:copy-closures? #$copy-inputs? - #:register-closures? #$register-closures? - #:system-directory #$os-derivation)) - (partitions (list (partition - (size #$(- disk-image-size - (* 10 (expt 2 20)))) - (label #$file-system-label) - (file-system #$file-system-type) - (bootable? #t) - (initializer initialize))))) - (initialize-hard-disk "/dev/vda" - #:partitions partitions - #:grub.cfg #$grub-configuration) - (reboot)))) + (with-imported-modules %vm-module-closure + #~(begin + (use-modules (gnu build vm) + (guix build utils)) + + (let ((inputs + '#$(append (list qemu parted grub e2fsprogs) + (map canonical-package + (list sed grep coreutils findutils gawk)) + (if register-closures? (list guix) '()))) + + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-register + '#$(map (match-lambda + ((name thing) thing) + ((name thing output) `(,thing ,output))) + inputs))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + + (let* ((graphs '#$(match inputs + (((names . _) ...) + names))) + (initialize (root-partition-initializer + #:closures graphs + #:copy-closures? #$copy-inputs? + #:register-closures? #$register-closures? + #:system-directory #$os-derivation)) + (partitions (list (partition + (size #$(- disk-image-size + (* 10 (expt 2 20)))) + (label #$file-system-label) + (file-system #$file-system-type) + (bootable? #t) + (initializer initialize))))) + (initialize-hard-disk "/dev/vda" + #:partitions partitions + #:grub.cfg #$grub-configuration) + (reboot))))) #:system system #:make-disk-image? #t #:disk-image-size disk-image-size |