gnu: Use 'gexp->file' in conjunction with 'with-imported-modules'.
* gnu/services.scm (activation-script): Remove code to set '%load-path' and use 'with-imported-modules' instead. (cleanup-gexp): Likewise. * gnu/system/vm.scm (%vm-module-closure): New variable. (expression->derivation-in-linux-vm): Remove #:modules. [loader]: Remove code to set '%load-path'. [builder]: Use %VM-MODULE-CLOSURE. (qemu-image): Use 'with-imported-modules'.master
Ludovic Courtès
parent
2b4185792d
commit
fd12989398
|
|
@ -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)))
|
||||
(with-monad %store-monad
|
||||
(with-imported-modules '((guix build utils))
|
||||
(return #~(begin
|
||||
(use-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)))))))
|
||||
;; 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)))
|
||||
(with-imported-modules %modules
|
||||
#~(begin
|
||||
(use-modules (gnu build activation))
|
||||
|
||||
(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."
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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) '())))
|
||||
(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)))
|
||||
;; 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)
|
||||
(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))))
|
||||
(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
|
||||
|
|
|
|||
Loading…
Reference in New Issue