summaryrefslogtreecommitdiff
path: root/gnu/system/vm.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system/vm.scm')
-rw-r--r--gnu/system/vm.scm207
1 files changed, 109 insertions, 98 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 73543896ef..df55f7c94e 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -33,13 +33,20 @@
#:use-module (gnu packages linux-initrd)
#:use-module ((gnu packages make-bootstrap)
#:select (%guile-static-stripped))
- #:use-module ((gnu packages system)
- #:select (mingetty))
+ #:use-module (gnu packages system)
+
+ #:use-module (gnu system shadow)
+ #:use-module (gnu system linux)
+ #:use-module (gnu system grub)
+ #:use-module (gnu system dmd)
+
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
+
#:export (expression->derivation-in-linux-vm
- qemu-image))
+ qemu-image
+ system-qemu-image))
;;; Commentary:
@@ -75,6 +82,9 @@ DISK-IMAGE-SIZE bytes and return it.
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."
+ ;; FIXME: Allow use of macros from other modules, as done in
+ ;; `build-expression->derivation'.
+
(define input-alist
(map (match-lambda
((input (? package? package))
@@ -197,10 +207,10 @@ It can be used to provide additional files, such as /etc files."
(define input->name+derivation
(match-lambda
((name (? package? package))
- `(,name . ,(derivation-path->output-path
+ `(,name . ,(derivation->output-path
(package-derivation store package system))))
((name (? package? package) sub-drv)
- `(,name . ,(derivation-path->output-path
+ `(,name . ,(derivation->output-path
(package-derivation store package system)
sub-drv)))
((input (and (? string?) (? store-path?) file))
@@ -294,6 +304,19 @@ It can be used to provide additional files, such as /etc files."
(primitive-load populate)
(chdir "/")))
+ (display "clearing file timestamps...\n")
+ (for-each (lambda (file)
+ (let ((s (lstat file)))
+ ;; XXX: Guile uses libc's 'utime' function
+ ;; (not 'futime'), so the timestamp of
+ ;; symlinks cannot be changed, and there
+ ;; are symlinks here pointing to
+ ;; /nix/store, which is the host,
+ ;; read-only store.
+ (unless (eq? (stat:type s) 'symlink)
+ (utime file 0 0 0 0))))
+ (find-files "/fs" ".*"))
+
(and (zero?
(system* grub "--no-floppy"
"--boot-directory" "/fs/boot"
@@ -327,100 +350,88 @@ It can be used to provide additional files, such as /etc files."
;;;
-;;; Guile 2.0 potluck examples.
+;;; Stand-alone VM image.
;;;
-(define (example1)
- (let ((store #f))
- (dynamic-wind
- (lambda ()
- (set! store (open-connection)))
- (lambda ()
- (parameterize ((%guile-for-build (package-derivation store guile-final)))
- (expression->derivation-in-linux-vm
- store "vm-test"
- '(begin
- (display "hello from boot!\n")
- (call-with-output-file "/xchg/hello"
- (lambda (p)
- (display "world" p)))))))
- (lambda ()
- (close-connection store)))))
-
-(define (/etc/shadow store accounts)
- "Return a /etc/shadow file for ACCOUNTS."
- (define contents
- (let loop ((accounts accounts)
- (result '()))
- (match accounts
- (((name uid gid comment home-dir shell) rest ...)
- (loop rest
- (cons (string-append name "::" (number->string uid)
- ":" (number->string gid)
- comment ":" home-dir ":" shell)
- result)))
- (()
- (string-concatenate-reverse result)))))
-
- (add-text-to-store store "shadow" contents '()))
-
-(define (example2)
- (let ((store #f))
- (dynamic-wind
- (lambda ()
- (set! store (open-connection)))
- (lambda ()
- (parameterize ((%guile-for-build (package-derivation store guile-final)))
- (let* ((bash-drv (package-derivation store bash))
- (bash-file (string-append (derivation-path->output-path bash-drv)
- "/bin/bash"))
- (passwd (/etc/shadow store
- `(("root" 0 0 "System administrator" "/"
- ,bash-file))))
- (populate
- (add-text-to-store store "populate-qemu-image"
- (object->string
- `(begin
- (mkdir-p "etc")
- (symlink ,(substring passwd 1)
- "etc/shadow")))
- (list passwd)))
- (out (derivation-path->output-path
- (package-derivation store mingetty)))
- (getty (string-append out "/sbin/mingetty"))
- (boot (add-text-to-store store "boot"
- (object->string
- `(begin
- ;; Become the session leader,
- ;; so that mingetty can do
- ;; 'TIOCSCTTY'.
- (setsid)
-
- ;; Directly into mingetty.
- (execl ,getty "mingetty"
- "--noclear" "tty1")))
- (list out)))
- (entries (list (menu-entry
- (label "Boot-to-Guile! (GNU System technology preview)")
- (linux linux-libre)
- (linux-arguments `("--root=/dev/vda1"
- ,(string-append "--load=" boot)))
- (initrd gnu-system-initrd))))
- (grub.cfg (grub-configuration-file store entries)))
- (qemu-image store
- #:grub-configuration grub.cfg
- #:populate populate
- #:disk-image-size (* 400 (expt 2 20))
- #:inputs-to-copy `(("boot" ,boot)
- ("linux" ,linux-libre)
- ("initrd" ,gnu-system-initrd)
- ("coreutils" ,coreutils)
- ("bash" ,bash)
- ("guile" ,guile-2.0)
- ("mingetty" ,mingetty)
-
- ("shadow" ,passwd))))))
- (lambda ()
- (close-connection store)))))
+(define (system-qemu-image store)
+ "Return the derivation of a QEMU image of the GNU system."
+ (define %pam-services
+ ;; Services known to PAM.
+ (list %pam-other-services
+ (unix-pam-service "login" #:allow-empty-passwords? #t)))
+
+ (define %dmd-services
+ ;; Services run by dmd.
+ (list (mingetty-service store "tty1")
+ (mingetty-service store "tty2")
+ (mingetty-service store "tty3")
+ (syslog-service store)))
+
+ (parameterize ((%guile-for-build (package-derivation store guile-final)))
+ (let* ((bash-drv (package-derivation store bash))
+ (bash-file (string-append (derivation->output-path bash-drv)
+ "/bin/bash"))
+ (dmd-drv (package-derivation store dmd))
+ (dmd-file (string-append (derivation->output-path dmd-drv)
+ "/bin/dmd"))
+ (dmd-conf (dmd-configuration-file store %dmd-services))
+ (accounts (list (vector "root" "" 0 0 "System administrator"
+ "/" bash-file)))
+ (passwd (passwd-file store accounts))
+ (shadow (passwd-file store accounts #:shadow? #t))
+ (group (add-text-to-store store "group"
+ "root:x:0:\n"))
+ (pam.d-drv (pam-services->directory store %pam-services))
+ (pam.d (derivation->output-path pam.d-drv))
+ (populate
+ (add-text-to-store store "populate-qemu-image"
+ (object->string
+ `(begin
+ (mkdir-p "etc")
+ (mkdir-p "var/log") ; for dmd
+ (symlink ,shadow "etc/shadow")
+ (symlink ,passwd "etc/passwd")
+ (symlink ,group "etc/group")
+ (symlink "/dev/null"
+ "etc/login.defs")
+ (symlink ,pam.d "etc/pam.d")
+ (mkdir-p "var/run")))
+ (list passwd)))
+ (out (derivation->output-path
+ (package-derivation store mingetty)))
+ (boot (add-text-to-store store "boot"
+ (object->string
+ `(execl ,dmd-file "dmd"
+ "--config" ,dmd-conf))
+ (list out)))
+ (entries (list (menu-entry
+ (label "Boot-to-Guile! (GNU System technology preview)")
+ (linux linux-libre)
+ (linux-arguments `("--root=/dev/vda1"
+ ,(string-append "--load=" boot)))
+ (initrd gnu-system-initrd))))
+ (grub.cfg (grub-configuration-file store entries)))
+ (build-derivations store (list pam.d-drv))
+ (qemu-image store
+ #:grub-configuration grub.cfg
+ #:populate populate
+ #:disk-image-size (* 400 (expt 2 20))
+ #:inputs-to-copy `(("boot" ,boot)
+ ("linux" ,linux-libre)
+ ("initrd" ,gnu-system-initrd)
+ ("coreutils" ,coreutils)
+ ("bash" ,bash)
+ ("guile" ,guile-2.0)
+ ("mingetty" ,mingetty)
+ ("dmd" ,dmd)
+
+ ;; Configuration.
+ ("dmd.conf" ,dmd-conf)
+ ("etc-pam.d" ,pam.d)
+ ("etc-passwd" ,passwd)
+ ("etc-shadow" ,shadow)
+ ("etc-group" ,group)
+ ,@(append-map service-inputs
+ %dmd-services))))))
;;; vm.scm ends here
generated by cgit v1.2.3 (git 2.25.4) at 2024-07-09 12:41:47 +0000