aboutsummaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/vm.scm232
1 files changed, 137 insertions, 95 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index a9f157d915..251114f770 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -59,6 +59,21 @@
;;;
;;; Code:
+(define (lower-inputs inputs)
+ "Turn any package from INPUTS into a derivation; return the corresponding
+input list as a monadic value."
+ (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))))
+
(define* (expression->derivation-in-linux-vm name exp
#:key
(system (%current-system))
@@ -168,21 +183,6 @@ made available under the /xchg CIFS share."
(mkdir out)
(copy-recursively "xchg" out)))))))
-
- (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))
@@ -458,24 +458,92 @@ input tuples."
#:modules '((guix build union))
#:guile-for-build guile)))
-(define (system-qemu-image)
- "Return the derivation of a QEMU image of the GNU system."
- (define build-user-gid 30000)
-
+(define* (file-union files
+ #:key (inputs '()) (name "file-union"))
+ "Return a derivation that builds a directory containing all of FILES. Each
+item in FILES must be a list where the first element is the file name to use
+in the new directory, and the second element is the target file.
+
+The subset of FILES corresponding to plain store files is automatically added
+as an inputs; additional inputs, such as derivations, are taken from INPUTS."
+ (mlet %store-monad ((inputs (lower-inputs inputs)))
+ (let ((inputs (append inputs
+ (filter (match-lambda
+ ((_ file)
+ (direct-store-path? file)))
+ files))))
+ (derivation-expression name
+ `(let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ ,@(map (match-lambda
+ ((name target)
+ `(symlink ,target ,name)))
+ files))
+
+ #:inputs inputs))))
+
+(define* (etc-directory #:key
+ (accounts '())
+ (groups '())
+ (pam-services '())
+ (profile "/var/run/current-system/profile"))
+ "Return a derivation that builds the static part of the /etc directory."
(mlet* %store-monad
- ((motd (text-file "motd" "
-Happy birthday, GNU! http://www.gnu.org/gnu30
+ ((services (package-file net-base "etc/services"))
+ (protocols (package-file net-base "etc/protocols"))
+ (rpc (package-file net-base "etc/rpc"))
+ (passwd (passwd-file accounts))
+ (shadow (passwd-file accounts #:shadow? #t))
+ (group (group-file groups))
+ (pam.d (pam-services->directory pam-services))
+ (login.defs (text-file "login.defs" "# Empty for now.\n"))
+ (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
+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 'guest' or 'root' with no password.
"))
- (%pam-services ->
- ;; Services known to PAM.
- (list %pam-other-services
- (unix-pam-service "login"
- #:allow-empty-passwords? #t
- #:motd motd)))
+ ;; TODO: Generate bashrc from packages' search-paths.
+ (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
+export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
+alias ls='ls -p --color'
+alias ll='ls -l'
+")))
+ (resolv.conf
+ ;; Name resolution for default QEMU settings.
+ ;; FIXME: Move to networking service.
+ (text-file "resolv.conf" "nameserver 10.0.2.3\n"))
+
+ (files -> `(("services" ,services)
+ ("protocols" ,protocols)
+ ("rpc" ,rpc)
+ ("pam.d" ,(derivation->output-path pam.d))
+ ("login.defs" ,login.defs)
+ ("issue" ,issue)
+ ("profile" ,bashrc)
+ ("passwd" ,passwd)
+ ("shadow" ,shadow)
+ ("group" ,group)
+ ("resolv.conf" ,resolv.conf))))
+ (file-union files
+ #:inputs `(("net" ,net-base)
+ ("pam.d" ,pam.d))
+ #:name "etc")))
+
+(define (system-qemu-image)
+ "Return the derivation of a QEMU image of the GNU system."
+ (define build-user-gid 30000)
- (services (listm %store-monad
+ (mlet* %store-monad
+ ((services (listm %store-monad
(host-name-service "gnu")
(mingetty-service "tty1")
(mingetty-service "tty2")
@@ -490,16 +558,18 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
;; QEMU networking settings.
(static-networking-service "eth0" "10.0.2.10"
#:gateway "10.0.2.2")))
+ (motd (text-file "motd" "
+Happy birthday, GNU! http://www.gnu.org/gnu30
- (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"))
+"))
+ (pam-services ->
+ ;; Services known to PAM.
+ (list %pam-other-services
+ (unix-pam-service "login"
+ #:allow-empty-passwords? #t
+ #:motd motd)))
- (etc-services (package-file net-base "etc/services"))
- (etc-protocols (package-file net-base "etc/protocols"))
- (etc-rpc (package-file net-base "etc/rpc"))
+ (build-accounts (guix-build-accounts 10 #:gid build-user-gid))
(bash-file (package-file bash "bin/bash"))
(dmd-file (package-file dmd "bin/dmd"))
@@ -519,23 +589,18 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
(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))
-
+ (groups -> (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)))))
(packages -> `(("coreutils" ,coreutils)
("bash" ,bash)
("guile" ,guile-2.0)
@@ -552,46 +617,34 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
("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
-export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
-alias ls='ls -p --color'
-alias ll='ls -l'
-")))
+ (etc-drv (etc-directory #:accounts accounts #:groups groups
+ #:pam-services pam-services
+ #:profile profile))
+ (etc -> (derivation->output-path etc-drv))
- (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
-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 '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)
+ ("/etc/static" -> ,etc)
+ ("/etc/shadow" -> "/etc/static/shadow")
+ ("/etc/passwd" -> "/etc/static/passwd")
+ ("/etc/group" -> "/etc/static/group")
+ ("/etc/login.defs" -> "/etc/static/login.defs")
+ ("/etc/pam.d" -> "/etc/static/pam.d")
+ ("/etc/resolv.conf" -> "/etc/static/resolv.conf")
+ ("/etc/profile" -> "/etc/static/profile")
+ ("/etc/issue" -> "/etc/static/issue")
+ ("/etc/services" -> "/etc/static/services")
+ ("/etc/protocols" -> "/etc/static/protocols")
+ ("/etc/rpc" -> "/etc/static/rpc")
(directory "/var/nix/gcroots")
("/var/nix/gcroots/default-profile" -> ,profile)
+ ("/var/nix/gcroots/etc-directory" -> ,etc)
(directory "/tmp")
(directory "/var/nix/profiles/per-user/root" 0 0)
(directory "/var/nix/profiles/per-user/guest"
@@ -617,20 +670,9 @@ You can log in as 'guest' or 'root' with no password.
#: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)
+ ("profile" ,profile-drv)
+ ("etc" ,etc-drv)
,@(append-map service-inputs
services)))))
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-16 06:24:49 +0000