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.scm202
1 files changed, 169 insertions, 33 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index df55f7c94e..0ed805510a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,6 +23,8 @@
#:use-module (guix packages)
#:use-module ((gnu packages base) #:select (%final-inputs
guile-final
+ gcc-final
+ glibc-final
coreutils))
#:use-module (gnu packages guile)
#:use-module (gnu packages bash)
@@ -31,6 +33,7 @@
#:use-module (gnu packages grub)
#:use-module (gnu packages linux)
#:use-module (gnu packages linux-initrd)
+ #:use-module (gnu packages package-management)
#:use-module ((gnu packages make-bootstrap)
#:select (%guile-static-stripped))
#:use-module (gnu packages system)
@@ -91,6 +94,10 @@ made available under the /xchg CIFS share."
`(,input . ,(package-output store package "out" system)))
((input (? package? package) sub-drv)
`(,input . ,(package-output store package sub-drv system)))
+ ((input (? derivation? drv))
+ `(,input . ,(derivation->output-path drv)))
+ ((input (? derivation? drv) sub-drv)
+ `(,input . ,(derivation->output-path drv sub-drv)))
((input (and (? string?) (? store-path?) file))
`(,input . ,file)))
inputs))
@@ -177,7 +184,8 @@ made available under the /xchg CIFS share."
`(,name ,(->drv package)
,@sub-drv))
((name (? string? file))
- `(,name ,file)))
+ `(,name ,file))
+ (tuple tuple))
inputs))
#:env-vars env-vars
#:modules (delete-duplicates
@@ -191,6 +199,7 @@ made available under the /xchg CIFS share."
(system (%current-system))
(disk-image-size (* 100 (expt 2 20)))
grub-configuration
+ (initialize-store? #f)
(populate #f)
(inputs '())
(inputs-to-copy '()))
@@ -199,11 +208,13 @@ disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
configuration file.
INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
-into the image being built.
+into the image being built. When INITIALIZE-STORE? is true, initialize the
+store database in the image so that Guix can be used in the image.
-When POPULATE is true, it must be the store file name of a Guile script to run
-in the disk image partition once it has been populated with INPUTS-TO-COPY.
-It can be used to provide additional files, such as /etc files."
+POPULATE is a list of directives stating directories or symlinks to be created
+in the disk image partition. It is evaluated once the image has been
+populated with INPUTS-TO-COPY. It can be used to provide additional files,
+such as /etc files."
(define input->name+derivation
(match-lambda
((name (? package? package))
@@ -213,6 +224,10 @@ It can be used to provide additional files, such as /etc files."
`(,name . ,(derivation->output-path
(package-derivation store package system)
sub-drv)))
+ ((name (? derivation? drv))
+ `(,name . ,(derivation->output-path drv)))
+ ((name (? derivation? drv) sub-drv)
+ `(,name . ,(derivation->output-path drv sub-drv)))
((input (and (? string?) (? store-path?) file))
`(,input . ,file))))
@@ -298,6 +313,36 @@ It can be used to provide additional files, such as /etc files."
;; Populate /dev.
(make-essential-device-nodes #:root "/fs")
+ ;; Optionally, register the inputs in the image's store.
+ (let* ((guix (assoc-ref %build-inputs "guix"))
+ (register (string-append guix
+ "/sbin/guix-register")))
+ ,@(if initialize-store?
+ (match inputs-to-copy
+ (((graph-files . _) ...)
+ (map (lambda (closure)
+ `(system* register "--prefix" "/fs"
+ ,(string-append "/xchg/"
+ closure)))
+ graph-files)))
+ '(#f)))
+
+ ;; Evaluate the POPULATE directives.
+ ,@(let loop ((directives populate)
+ (statements '()))
+ (match directives
+ (()
+ (reverse statements))
+ ((('directory name) rest ...)
+ (loop rest
+ (cons `(mkdir-p ,(string-append "/fs" name))
+ statements)))
+ (((new '-> old) rest ...)
+ (loop rest
+ (cons `(symlink ,old
+ ,(string-append "/fs" new))
+ statements)))))
+
(and=> (assoc-ref %build-inputs "populate")
(lambda (populate)
(chdir "/fs")
@@ -337,8 +382,8 @@ It can be used to provide additional files, such as /etc files."
("gawk" ,(car (assoc-ref %final-inputs "gawk")))
("util-linux" ,util-linux)
- ,@(if populate
- `(("populate" ,populate))
+ ,@(if initialize-store?
+ `(("guix" ,guix-0.4))
'())
,@inputs-to-copy)
@@ -353,19 +398,73 @@ It can be used to provide additional files, such as /etc files."
;;; Stand-alone VM image.
;;;
+(define* (union store inputs
+ #:key (guile (%guile-for-build)) (system (%current-system))
+ (name "union"))
+ "Return a derivation that builds the union of INPUTS. INPUTS is a list of
+input tuples."
+ (define builder
+ `(begin
+ (use-modules (guix build union))
+
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (let ((output (assoc-ref %outputs "out"))
+ (inputs (map cdr %build-inputs)))
+ (format #t "building union `~a' with ~a packages...~%"
+ output (length inputs))
+ (union-build output inputs))))
+
+ (build-expression->derivation store name system builder
+ (map (match-lambda
+ ((name (? package? p))
+ `(,name ,(package-derivation store p
+ system)))
+ ((name (? package? p) output)
+ `(,name ,(package-derivation store p
+ system)
+ ,output))
+ (x x))
+ inputs)
+ #:modules '((guix build union))
+ #:guile-for-build guile))
+
(define (system-qemu-image store)
"Return the derivation of a QEMU image of the GNU system."
+ (define motd
+ (add-text-to-store store "motd" "
+Happy birthday, GNU! http://www.gnu.org/gnu30
+
+"))
+
(define %pam-services
;; Services known to PAM.
(list %pam-other-services
- (unix-pam-service "login" #:allow-empty-passwords? #t)))
+ (unix-pam-service "login"
+ #:allow-empty-passwords? #t
+ #:motd motd)))
(define %dmd-services
;; Services run by dmd.
- (list (mingetty-service store "tty1")
+ (list (host-name-service store "gnu")
+ (mingetty-service store "tty1")
(mingetty-service store "tty2")
(mingetty-service store "tty3")
- (syslog-service store)))
+ (mingetty-service store "tty4")
+ (mingetty-service store "tty5")
+ (mingetty-service store "tty6")
+ (syslog-service store)
+ (guix-service store #:guix guix-0.4)
+ (nscd-service store)
+
+ ;; QEMU networking settings.
+ (static-networking-service store "eth0" "10.0.2.10")))
+
+ (define resolv.conf
+ ;; Name resolution for default QEMU settings.
+ (add-text-to-store store "resolv.conf"
+ "nameserver 10.0.2.3\n"))
(parameterize ((%guile-for-build (package-derivation store guile-final)))
(let* ((bash-drv (package-derivation store bash))
@@ -383,20 +482,53 @@ It can be used to provide additional files, such as /etc files."
"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)))
+
+ (packages `(("coreutils" ,coreutils)
+ ("bash" ,bash)
+ ("guile" ,guile-2.0)
+ ("dmd" ,dmd)
+ ("gcc" ,gcc-final)
+ ("libc" ,glibc-final)
+ ("inetutils" ,inetutils)
+ ("guix" ,guix-0.4)))
+
+ ;; TODO: Replace with a real profile with a manifest.
+ ;; TODO: Generate bashrc from packages' search-paths.
+ (profile-drv (union store packages
+ #:name "default-profile"))
+ (profile (derivation->output-path profile-drv))
+ (bashrc (add-text-to-store store "bashrc"
+ (string-append "
+export PS1='\\u@\\h\\$ '
+export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin
+export CPATH=$HOME/.guix-profile/include:" profile "/include
+export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
+alias ls='ls -p --color'
+alias ll='ls -l'
+")))
+
+ (issue (add-text-to-store store "issue" "
+This is an alpha preview of the GNU system. Welcome.
+
+This image features the GNU Guix package manager, which was used to
+build it (http://www.gnu.org/software/guix/). The init system is
+GNU dmd (http://www.gnu.org/software/dmd/).
+
+You can log in as 'root' with no password.
+"))
+
+ (populate `((directory "/etc")
+ (directory "/var/log") ; for dmd
+ (directory "/var/run/nscd")
+ ("/etc/shadow" -> ,shadow)
+ ("/etc/passwd" -> ,passwd)
+ ("/etc/login.defs" -> "/dev/null")
+ ("/etc/pam.d" -> ,pam.d)
+ ("/etc/resolv.conf" -> ,resolv.conf)
+ ("/etc/profile" -> ,bashrc)
+ ("/etc/issue" -> ,issue)
+ (directory "/var/nix/gcroots")
+ ("/var/nix/gcroots/default-profile" -> ,profile)))
(out (derivation->output-path
(package-derivation store mingetty)))
(boot (add-text-to-store store "boot"
@@ -405,32 +537,36 @@ It can be used to provide additional files, such as /etc files."
"--config" ,dmd-conf))
(list out)))
(entries (list (menu-entry
- (label "Boot-to-Guile! (GNU System technology preview)")
+ (label (string-append
+ "GNU System with Linux-Libre "
+ (package-version linux-libre)
+ " (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))
+ #:disk-image-size (* 500 (expt 2 20))
+ #:initialize-store? #t
#:inputs-to-copy `(("boot" ,boot)
("linux" ,linux-libre)
("initrd" ,gnu-system-initrd)
- ("coreutils" ,coreutils)
- ("bash" ,bash)
- ("guile" ,guile-2.0)
- ("mingetty" ,mingetty)
- ("dmd" ,dmd)
+ ("pam.d" ,pam.d-drv)
+ ("profile" ,profile-drv)
;; Configuration.
("dmd.conf" ,dmd-conf)
- ("etc-pam.d" ,pam.d)
+ ("etc-pam.d" ,pam.d-drv)
("etc-passwd" ,passwd)
("etc-shadow" ,shadow)
("etc-group" ,group)
+ ("etc-resolv.conf" ,resolv.conf)
+ ("etc-bashrc" ,bashrc)
+ ("etc-issue" ,issue)
+ ("etc-motd" ,motd)
,@(append-map service-inputs
%dmd-services))))))
generated by cgit v1.2.3 (git 2.44.0) at 2024-07-06 08:38:09 +0000