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.scm833
1 files changed, 417 insertions, 416 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 83b9f33456..db055fa5fc 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -21,6 +21,7 @@
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix monads)
#:use-module ((gnu packages base)
#:select (%final-inputs
guile-final gcc-final glibc-final
@@ -58,7 +59,7 @@
;;;
;;; Code:
-(define* (expression->derivation-in-linux-vm store name exp
+(define* (expression->derivation-in-linux-vm name exp
#:key
(system (%current-system))
(inputs '())
@@ -89,23 +90,23 @@ made available under the /xchg CIFS share."
;; `build-expression->derivation'.
(define input-alist
- (map (match-lambda
- ((input (? package? package))
- `(,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))
-
- (define exp*
- ;; EXP, but with INPUTS available.
- `(let ((%build-inputs ',input-alist))
- ,exp))
+ (with-monad %store-monad
+ (map (match-lambda
+ ((input (? package? package))
+ (mlet %store-monad ((out (package-file package #:system system)))
+ (return `(,input . ,out))))
+ ((input (? package? package) sub-drv)
+ (mlet %store-monad ((out (package-file package
+ #:output sub-drv
+ #:system system)))
+ (return `(,input . ,out))))
+ ((input (? derivation? drv))
+ (return `(,input . ,(derivation->output-path drv))))
+ ((input (? derivation? drv) sub-drv)
+ (return `(,input . ,(derivation->output-path drv sub-drv))))
+ ((input (and (? string?) (? store-path?) file))
+ (return `(,input . ,file))))
+ inputs)))
(define builder
;; Code that launches the VM that evaluates EXP.
@@ -167,34 +168,43 @@ made available under the /xchg CIFS share."
(mkdir out)
(copy-recursively "xchg" out)))))))
- (let ((user-builder (add-text-to-store store "builder-in-linux-vm"
- (object->string exp*)
- '()))
- (->drv (cut package-derivation store <> system))
- (coreutils (car (assoc-ref %final-inputs "coreutils"))))
- (build-expression->derivation store name system builder
- `(("qemu" ,(->drv qemu))
- ("linux" ,(->drv linux))
- ("initrd" ,(->drv initrd))
- ("coreutils" ,(->drv coreutils))
- ("builder" ,user-builder)
- ,@(map (match-lambda
- ((name (? package? package)
- sub-drv ...)
- `(,name ,(->drv package)
- ,@sub-drv))
- ((name (? string? file))
- `(,name ,file))
- (tuple tuple))
- inputs))
- #:env-vars env-vars
- #:modules (delete-duplicates
- `((guix build utils)
- ,@modules))
- #:guile-for-build guile-for-build
- #:references-graphs references-graphs)))
-
-(define* (qemu-image store #:key
+
+ (define (lower-inputs inputs)
+ ;; Turn any package in INPUTS into a derivation.
+ (with-monad %store-monad
+ (sequence %store-monad
+ (map (match-lambda
+ ((name (? package? package) sub-drv ...)
+ (mlet %store-monad ((drv (package->derivation package)))
+ (return `(,name ,drv ,@sub-drv))))
+ ((name (? string? file))
+ (return `(,name ,file)))
+ (tuple
+ (return tuple)))
+ inputs))))
+
+ (mlet* %store-monad
+ ((input-alist (sequence %store-monad input-alist))
+ (exp* -> `(let ((%build-inputs ',input-alist))
+ ,exp))
+ (user-builder (text-file "builder-in-linux-vm"
+ (object->string exp*)))
+ (coreutils -> (car (assoc-ref %final-inputs "coreutils")))
+ (inputs (lower-inputs `(("qemu" ,qemu)
+ ("linux" ,linux)
+ ("initrd" ,initrd)
+ ("coreutils" ,coreutils)
+ ("builder" ,user-builder)
+ ,@inputs))))
+ (derivation-expression name system builder inputs
+ #:env-vars env-vars
+ #:modules (delete-duplicates
+ `((guix build utils)
+ ,@modules))
+ #:guile-for-build guile-for-build
+ #:references-graphs references-graphs)))
+
+(define* (qemu-image #:key
(name "qemu-image")
(system (%current-system))
(disk-image-size (* 100 (expt 2 20)))
@@ -215,203 +225,206 @@ 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))
- `(,name . ,(derivation->output-path
- (package-derivation store package system))))
- ((name (? package? package) sub-drv)
- `(,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))))
-
- (expression->derivation-in-linux-vm
- store "qemu-image"
- `(let ()
- (use-modules (ice-9 rdelim)
- (srfi srfi-1)
- (guix build utils)
- (guix build linux-initrd))
-
- (let ((parted (string-append (assoc-ref %build-inputs "parted")
- "/sbin/parted"))
- (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
- "/sbin/mkfs.ext3"))
- (grub (string-append (assoc-ref %build-inputs "grub")
- "/sbin/grub-install"))
- (umount (string-append (assoc-ref %build-inputs "util-linux")
- "/bin/umount")) ; XXX: add to Guile
- (grub.cfg (assoc-ref %build-inputs "grub.cfg")))
-
- (define (read-reference-graph port)
- ;; Return a list of store paths from the reference graph at PORT.
- ;; The data at PORT is the format produced by #:references-graphs.
- (let loop ((line (read-line port))
- (result '()))
- (cond ((eof-object? line)
- (delete-duplicates result))
- ((string-prefix? "/" line)
- (loop (read-line port)
- (cons line result)))
- (else
- (loop (read-line port)
- result)))))
-
- (define (things-to-copy)
- ;; Return the list of store files to copy to the image.
- (define (graph-from-file file)
- (call-with-input-file file
- read-reference-graph))
-
- ,(match inputs-to-copy
- (((graph-files . _) ...)
- `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
- graph-files))
- (paths (append-map graph-from-file graph-files)))
- (delete-duplicates paths)))
- (#f ''())))
-
- ;; GRUB is full of shell scripts.
- (setenv "PATH"
- (string-append (dirname grub) ":"
- (assoc-ref %build-inputs "coreutils") "/bin:"
- (assoc-ref %build-inputs "findutils") "/bin:"
- (assoc-ref %build-inputs "sed") "/bin:"
- (assoc-ref %build-inputs "grep") "/bin:"
- (assoc-ref %build-inputs "gawk") "/bin"))
-
- (display "creating partition table...\n")
- (and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
- "mkpart" "primary" "ext2" "1MiB"
- ,(format #f "~aB"
- (- disk-image-size
- (* 5 (expt 2 20))))))
- (begin
- (display "creating ext3 partition...\n")
- (and (zero? (system* mkfs "-F" "/dev/vda1"))
- (let ((store (string-append "/fs" ,%store-directory)))
- (display "mounting partition...\n")
- (mkdir "/fs")
- (mount "/dev/vda1" "/fs" "ext3")
- (mkdir-p "/fs/boot/grub")
- (symlink grub.cfg "/fs/boot/grub/grub.cfg")
-
- ;; Populate the image's store.
- (mkdir-p store)
- (chmod store #o1775)
- (for-each (lambda (thing)
- (copy-recursively thing
- (string-append "/fs"
- thing)))
- (cons grub.cfg (things-to-copy)))
-
- ;; 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)))
- ((('directory name uid gid) rest ...)
- (let ((dir (string-append "/fs" name)))
- (loop rest
- (cons* `(chown ,dir ,uid ,gid)
- `(mkdir-p ,dir)
- statements))))
- (((new '-> old) rest ...)
- (loop rest
- (cons `(symlink ,old
- ,(string-append "/fs" new))
- statements)))))
-
- (and=> (assoc-ref %build-inputs "populate")
- (lambda (populate)
- (chdir "/fs")
- (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"
- "/dev/vda"))
- (zero? (system* umount "/fs"))
- (reboot))))))))
- #:system system
- #:inputs `(("parted" ,parted)
- ("grub" ,grub)
- ("e2fsprogs" ,e2fsprogs)
- ("grub.cfg" ,grub-configuration)
-
- ;; For shell scripts.
- ("sed" ,(car (assoc-ref %final-inputs "sed")))
- ("grep" ,(car (assoc-ref %final-inputs "grep")))
- ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
- ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
- ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
- ("util-linux" ,util-linux)
-
- ,@(if initialize-store?
- `(("guix" ,guix))
- '())
-
- ,@inputs-to-copy)
- #:make-disk-image? #t
- #:disk-image-size disk-image-size
- #:references-graphs (map input->name+derivation inputs-to-copy)
- #:modules '((guix build utils)
- (guix build linux-initrd))))
+ (define (input->name+derivation tuple)
+ (with-monad %store-monad
+ (match tuple
+ ((name (? package? package))
+ (mlet %store-monad ((drv (package->derivation package system)))
+ (return `(,name . ,(derivation->output-path drv)))))
+ ((name (? package? package) sub-drv)
+ (mlet %store-monad ((drv (package->derivation package system)))
+ (return `(,name . ,(derivation->output-path drv sub-drv)))))
+ ((name (? derivation? drv))
+ (return `(,name . ,(derivation->output-path drv))))
+ ((name (? derivation? drv) sub-drv)
+ (return `(,name . ,(derivation->output-path drv sub-drv))))
+ ((input (and (? string?) (? store-path?) file))
+ (return `(,input . ,file))))))
+
+ (mlet %store-monad
+ ((graph (sequence %store-monad
+ (map input->name+derivation inputs-to-copy))))
+ (expression->derivation-in-linux-vm
+ "qemu-image"
+ `(let ()
+ (use-modules (ice-9 rdelim)
+ (srfi srfi-1)
+ (guix build utils)
+ (guix build linux-initrd))
+
+ (let ((parted (string-append (assoc-ref %build-inputs "parted")
+ "/sbin/parted"))
+ (mkfs (string-append (assoc-ref %build-inputs "e2fsprogs")
+ "/sbin/mkfs.ext3"))
+ (grub (string-append (assoc-ref %build-inputs "grub")
+ "/sbin/grub-install"))
+ (umount (string-append (assoc-ref %build-inputs "util-linux")
+ "/bin/umount")) ; XXX: add to Guile
+ (grub.cfg (assoc-ref %build-inputs "grub.cfg")))
+
+ (define (read-reference-graph port)
+ ;; Return a list of store paths from the reference graph at PORT.
+ ;; The data at PORT is the format produced by #:references-graphs.
+ (let loop ((line (read-line port))
+ (result '()))
+ (cond ((eof-object? line)
+ (delete-duplicates result))
+ ((string-prefix? "/" line)
+ (loop (read-line port)
+ (cons line result)))
+ (else
+ (loop (read-line port)
+ result)))))
+
+ (define (things-to-copy)
+ ;; Return the list of store files to copy to the image.
+ (define (graph-from-file file)
+ (call-with-input-file file
+ read-reference-graph))
+
+ ,(match inputs-to-copy
+ (((graph-files . _) ...)
+ `(let* ((graph-files ',(map (cut string-append "/xchg/" <>)
+ graph-files))
+ (paths (append-map graph-from-file graph-files)))
+ (delete-duplicates paths)))
+ (#f ''())))
+
+ ;; GRUB is full of shell scripts.
+ (setenv "PATH"
+ (string-append (dirname grub) ":"
+ (assoc-ref %build-inputs "coreutils") "/bin:"
+ (assoc-ref %build-inputs "findutils") "/bin:"
+ (assoc-ref %build-inputs "sed") "/bin:"
+ (assoc-ref %build-inputs "grep") "/bin:"
+ (assoc-ref %build-inputs "gawk") "/bin"))
+
+ (display "creating partition table...\n")
+ (and (zero? (system* parted "/dev/vda" "mklabel" "msdos"
+ "mkpart" "primary" "ext2" "1MiB"
+ ,(format #f "~aB"
+ (- disk-image-size
+ (* 5 (expt 2 20))))))
+ (begin
+ (display "creating ext3 partition...\n")
+ (and (zero? (system* mkfs "-F" "/dev/vda1"))
+ (let ((store (string-append "/fs" ,%store-directory)))
+ (display "mounting partition...\n")
+ (mkdir "/fs")
+ (mount "/dev/vda1" "/fs" "ext3")
+ (mkdir-p "/fs/boot/grub")
+ (symlink grub.cfg "/fs/boot/grub/grub.cfg")
+
+ ;; Populate the image's store.
+ (mkdir-p store)
+ (chmod store #o1775)
+ (for-each (lambda (thing)
+ (copy-recursively thing
+ (string-append "/fs"
+ thing)))
+ (cons grub.cfg (things-to-copy)))
+
+ ;; 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)))
+ ((('directory name uid gid) rest ...)
+ (let ((dir (string-append "/fs" name)))
+ (loop rest
+ (cons* `(chown ,dir ,uid ,gid)
+ `(mkdir-p ,dir)
+ statements))))
+ (((new '-> old) rest ...)
+ (loop rest
+ (cons `(symlink ,old
+ ,(string-append "/fs" new))
+ statements)))))
+
+ (and=> (assoc-ref %build-inputs "populate")
+ (lambda (populate)
+ (chdir "/fs")
+ (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"
+ "/dev/vda"))
+ (zero? (system* umount "/fs"))
+ (reboot))))))))
+ #:system system
+ #:inputs `(("parted" ,parted)
+ ("grub" ,grub)
+ ("e2fsprogs" ,e2fsprogs)
+ ("grub.cfg" ,grub-configuration)
+
+ ;; For shell scripts.
+ ("sed" ,(car (assoc-ref %final-inputs "sed")))
+ ("grep" ,(car (assoc-ref %final-inputs "grep")))
+ ("coreutils" ,(car (assoc-ref %final-inputs "coreutils")))
+ ("findutils" ,(car (assoc-ref %final-inputs "findutils")))
+ ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
+ ("util-linux" ,util-linux)
+
+ ,@(if initialize-store?
+ `(("guix" ,guix))
+ '())
+
+ ,@inputs-to-copy)
+ #:make-disk-image? #t
+ #:disk-image-size disk-image-size
+ #:references-graphs graph
+ #:modules '((guix build utils)
+ (guix build linux-initrd)))))
;;;
;;; Stand-alone VM image.
;;;
-(define* (union store inputs
+(define* (union 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
+ '(begin
(use-modules (guix build union))
(setvbuf (current-output-port) _IOLBF)
@@ -423,132 +436,124 @@ input tuples."
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)
+ (mlet %store-monad
+ ((inputs (sequence %store-monad
+ (map (match-lambda
+ ((name (? package? p))
+ (mlet %store-monad
+ ((drv (package->derivation p system)))
+ (return `(,name ,drv))))
+ ((name (? package? p) output)
+ (mlet %store-monad
+ ((drv (package->derivation p system)))
+ (return `(,name ,drv ,output))))
+ (x
+ (return x)))
+ inputs))))
+ (derivation-expression name system builder
+ inputs
+ #:modules '((guix build union))
+ #:guile-for-build guile)))
+
+(define (system-qemu-image)
"Return the derivation of a QEMU image of the GNU system."
- (define motd
- (add-text-to-store store "motd" "
+ (define build-user-gid 30000)
+
+ (mlet* %store-monad
+ ((motd (text-file "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
- #:motd motd)))
-
- (define %dmd-services
- ;; Services run by dmd.
- (list (host-name-service store "gnu")
- (mingetty-service store "tty1")
- (mingetty-service store "tty2")
- (mingetty-service store "tty3")
- (mingetty-service store "tty4")
- (mingetty-service store "tty5")
- (mingetty-service store "tty6")
- (syslog-service store)
- (guix-service store)
- (nscd-service store)
-
- ;; QEMU networking settings.
- (static-networking-service store "eth0" "10.0.2.10"
- #:gateway "10.0.2.2")))
-
- (define build-user-gid 30000)
-
- (define build-accounts
- (guix-build-accounts store 10 #:gid build-user-gid))
-
- (define resolv.conf
- ;; Name resolution for default QEMU settings.
- (add-text-to-store store "resolv.conf"
- "nameserver 10.0.2.3\n"))
-
- (define etc-services
- (string-append (package-output store net-base) "/etc/services"))
- (define etc-protocols
- (string-append (package-output store net-base) "/etc/protocols"))
- (define etc-rpc
- (string-append (package-output store net-base) "/etc/rpc"))
-
- (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 (cons* (user-account
- (name "root")
- (password "")
- (uid 0) (gid 0)
- (comment "System administrator")
- (home-directory "/")
- (shell bash-file))
- (user-account
- (name "guest")
- (password "")
- (uid 1000) (gid 100)
- (comment "Guest of GNU")
- (home-directory "/home/guest")
- (shell bash-file))
- build-accounts))
- (passwd (passwd-file store accounts))
- (shadow (passwd-file store accounts #:shadow? #t))
- (group (group-file store
- (list (user-group
- (name "root")
- (id 0))
- (user-group
- (name "users")
- (id 100)
- (members '("guest")))
- (user-group
- (name "guixbuild")
- (id build-user-gid)
- (members (map user-account-name
- build-accounts))))))
- (pam.d-drv (pam-services->directory store %pam-services))
- (pam.d (derivation->output-path pam.d-drv))
-
- (packages `(("coreutils" ,coreutils)
- ("bash" ,bash)
- ("guile" ,guile-2.0)
- ("dmd" ,dmd)
- ("gcc" ,gcc-final)
- ("libc" ,glibc-final)
- ("inetutils" ,inetutils)
- ("findutils" ,findutils)
- ("grep" ,grep)
- ("sed" ,sed)
- ("procps" ,procps)
- ("psmisc" ,psmisc)
- ("zile" ,zile)
- ("guix" ,guix)))
-
- ;; 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 "
+ (%pam-services ->
+ ;; Services known to PAM.
+ (list %pam-other-services
+ (unix-pam-service "login"
+ #:allow-empty-passwords? #t
+ #:motd motd)))
+
+ (services (listm %store-monad
+ (host-name-service "gnu")
+ (mingetty-service "tty1")
+ (mingetty-service "tty2")
+ (mingetty-service "tty3")
+ (mingetty-service "tty4")
+ (mingetty-service "tty5")
+ (mingetty-service "tty6")
+ (syslog-service)
+ (guix-service)
+ (nscd-service)
+
+ ;; QEMU networking settings.
+ (static-networking-service "eth0" "10.0.2.10"
+ #:gateway "10.0.2.2")))
+
+ (build-accounts (guix-build-accounts 10 #:gid build-user-gid))
+
+ (resolv.conf
+ ;; Name resolution for default QEMU settings.
+ (text-file "resolv.conf" "nameserver 10.0.2.3\n"))
+
+ (etc-services (package-file net-base "etc/services"))
+ (etc-protocols (package-file net-base "etc/protocols"))
+ (etc-rpc (package-file net-base "etc/rpc"))
+
+ (bash-file (package-file bash "bin/bash"))
+ (dmd-file (package-file dmd "bin/dmd"))
+ (dmd-conf (dmd-configuration-file services))
+ (accounts -> (cons* (user-account
+ (name "root")
+ (password "")
+ (uid 0) (gid 0)
+ (comment "System administrator")
+ (home-directory "/")
+ (shell bash-file))
+ (user-account
+ (name "guest")
+ (password "")
+ (uid 1000) (gid 100)
+ (comment "Guest of GNU")
+ (home-directory "/home/guest")
+ (shell bash-file))
+ build-accounts))
+ (passwd (passwd-file accounts))
+ (shadow (passwd-file accounts #:shadow? #t))
+ (group (group-file (list (user-group
+ (name "root")
+ (id 0))
+ (user-group
+ (name "users")
+ (id 100)
+ (members '("guest")))
+ (user-group
+ (name "guixbuild")
+ (id build-user-gid)
+ (members (map user-account-name
+ build-accounts))))))
+ (pam.d-drv (pam-services->directory %pam-services))
+ (pam.d -> (derivation->output-path pam.d-drv))
+
+ (packages -> `(("coreutils" ,coreutils)
+ ("bash" ,bash)
+ ("guile" ,guile-2.0)
+ ("dmd" ,dmd)
+ ("gcc" ,gcc-final)
+ ("libc" ,glibc-final)
+ ("inetutils" ,inetutils)
+ ("findutils" ,findutils)
+ ("grep" ,grep)
+ ("sed" ,sed)
+ ("procps" ,procps)
+ ("psmisc" ,psmisc)
+ ("zile" ,zile)
+ ("guix" ,guix)))
+
+ ;; TODO: Replace with a real profile with a manifest.
+ ;; TODO: Generate bashrc from packages' search-paths.
+ (profile-drv (union packages
+ #:name "default-profile"))
+ (profile -> (derivation->output-path profile-drv))
+ (bashrc (text-file "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
@@ -557,7 +562,7 @@ alias ls='ls -p --color'
alias ll='ls -l'
")))
- (issue (add-text-to-store store "issue" "
+ (issue (text-file "issue" "
This is an alpha preview of the GNU system. Welcome.
This image features the GNU Guix package manager, which was used to
@@ -567,67 +572,63 @@ GNU dmd (http://www.gnu.org/software/dmd/).
You can log in as 'guest' or 'root' with no password.
"))
- (populate `((directory "/nix/store" 0 ,build-user-gid)
- (directory "/etc")
- (directory "/var/log") ; for dmd
- (directory "/var/run/nscd")
- ("/etc/shadow" -> ,shadow)
- ("/etc/passwd" -> ,passwd)
- ("/etc/group" -> ,group)
- ("/etc/login.defs" -> "/dev/null")
- ("/etc/pam.d" -> ,pam.d)
- ("/etc/resolv.conf" -> ,resolv.conf)
- ("/etc/profile" -> ,bashrc)
- ("/etc/issue" -> ,issue)
- ("/etc/services" -> ,etc-services)
- ("/etc/protocols" -> ,etc-protocols)
- ("/etc/rpc" -> ,etc-rpc)
- (directory "/var/nix/gcroots")
- ("/var/nix/gcroots/default-profile" -> ,profile)
- (directory "/tmp")
- (directory "/var/nix/profiles/per-user/root" 0 0)
- (directory "/var/nix/profiles/per-user/guest"
- 1000 100)
- (directory "/home/guest" 1000 100)))
- (out (derivation->output-path
- (package-derivation store mingetty)))
- (boot (add-text-to-store store "boot"
- (object->string
- `(execl ,dmd-file "dmd"
- "--config" ,dmd-conf))))
- (entries (list (menu-entry
- (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)))
- (qemu-image store
- #:grub-configuration grub.cfg
- #:populate populate
- #:disk-image-size (* 550 (expt 2 20))
- #:initialize-store? #t
- #:inputs-to-copy `(("boot" ,boot)
- ("linux" ,linux-libre)
- ("initrd" ,gnu-system-initrd)
- ("pam.d" ,pam.d-drv)
- ("profile" ,profile-drv)
-
- ;; Configuration.
- ("dmd.conf" ,dmd-conf)
- ("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)
- ("net-base" ,net-base)
- ,@(append-map service-inputs
- %dmd-services))))))
+ (populate -> `((directory "/nix/store" 0 ,build-user-gid)
+ (directory "/etc")
+ (directory "/var/log") ; for dmd
+ (directory "/var/run/nscd")
+ ("/etc/shadow" -> ,shadow)
+ ("/etc/passwd" -> ,passwd)
+ ("/etc/group" -> ,group)
+ ("/etc/login.defs" -> "/dev/null")
+ ("/etc/pam.d" -> ,pam.d)
+ ("/etc/resolv.conf" -> ,resolv.conf)
+ ("/etc/profile" -> ,bashrc)
+ ("/etc/issue" -> ,issue)
+ ("/etc/services" -> ,etc-services)
+ ("/etc/protocols" -> ,etc-protocols)
+ ("/etc/rpc" -> ,etc-rpc)
+ (directory "/var/nix/gcroots")
+ ("/var/nix/gcroots/default-profile" -> ,profile)
+ (directory "/tmp")
+ (directory "/var/nix/profiles/per-user/root" 0 0)
+ (directory "/var/nix/profiles/per-user/guest"
+ 1000 100)
+ (directory "/home/guest" 1000 100)))
+ (boot (text-file "boot" (object->string
+ `(execl ,dmd-file "dmd"
+ "--config" ,dmd-conf))))
+ (entries -> (list (return (menu-entry
+ (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 entries)))
+ (qemu-image #:grub-configuration grub.cfg
+ #:populate populate
+ #:disk-image-size (* 550 (expt 2 20))
+ #:initialize-store? #t
+ #:inputs-to-copy `(("boot" ,boot)
+ ("linux" ,linux-libre)
+ ("initrd" ,gnu-system-initrd)
+ ("pam.d" ,pam.d-drv)
+ ("profile" ,profile-drv)
+
+ ;; Configuration.
+ ("dmd.conf" ,dmd-conf)
+ ("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)
+ ("net-base" ,net-base)
+ ,@(append-map service-inputs
+ services)))))
;;; vm.scm ends here
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-06 13:36:47 +0000