Browse Source

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'.
version-0.11.0
Ludovic Courtès 6 years ago
parent
commit
fd12989398
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 94
      gnu/services.scm
  2. 122
      gnu/system/vm.scm

94
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."

122
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

Loading…
Cancel
Save