gnu: vm: Factorize /etc creation.
* gnu/system/vm.scm (expression->derivation-in-linux-vm)[lower-inputs]: Move to top-level... (lower-inputs): ... here. New variable. (file-union, etc-directory): New procedures. (system-qemu-image): Use 'etc-directory'; remove redundant code, and register the result of 'etc-directory' as a GC root.
This commit is contained in:
Ludovic Courtès
parent
dc47b181da
commit
0b8a376b68
|
|
@ -59,6 +59,21 @@
|
||||||
;;;
|
;;;
|
||||||
;;; Code:
|
;;; 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
|
(define* (expression->derivation-in-linux-vm name exp
|
||||||
#:key
|
#:key
|
||||||
(system (%current-system))
|
(system (%current-system))
|
||||||
|
|
@ -168,21 +183,6 @@ made available under the /xchg CIFS share."
|
||||||
(mkdir out)
|
(mkdir out)
|
||||||
(copy-recursively "xchg" 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
|
(mlet* %store-monad
|
||||||
((input-alist (sequence %store-monad input-alist))
|
((input-alist (sequence %store-monad input-alist))
|
||||||
(exp* -> `(let ((%build-inputs ',input-alist))
|
(exp* -> `(let ((%build-inputs ',input-alist))
|
||||||
|
|
@ -458,24 +458,92 @@ input tuples."
|
||||||
#:modules '((guix build union))
|
#:modules '((guix build union))
|
||||||
#:guile-for-build guile)))
|
#:guile-for-build guile)))
|
||||||
|
|
||||||
|
(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
|
||||||
|
((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.
|
||||||
|
"))
|
||||||
|
|
||||||
|
;; 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)
|
(define (system-qemu-image)
|
||||||
"Return the derivation of a QEMU image of the GNU system."
|
"Return the derivation of a QEMU image of the GNU system."
|
||||||
(define build-user-gid 30000)
|
(define build-user-gid 30000)
|
||||||
|
|
||||||
(mlet* %store-monad
|
(mlet* %store-monad
|
||||||
((motd (text-file "motd" "
|
((services (listm %store-monad
|
||||||
Happy birthday, GNU! http://www.gnu.org/gnu30
|
|
||||||
|
|
||||||
"))
|
|
||||||
|
|
||||||
(%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")
|
(host-name-service "gnu")
|
||||||
(mingetty-service "tty1")
|
(mingetty-service "tty1")
|
||||||
(mingetty-service "tty2")
|
(mingetty-service "tty2")
|
||||||
|
|
@ -490,17 +558,19 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
|
||||||
;; QEMU networking settings.
|
;; QEMU networking settings.
|
||||||
(static-networking-service "eth0" "10.0.2.10"
|
(static-networking-service "eth0" "10.0.2.10"
|
||||||
#:gateway "10.0.2.2")))
|
#:gateway "10.0.2.2")))
|
||||||
|
(motd (text-file "motd" "
|
||||||
|
Happy birthday, GNU! http://www.gnu.org/gnu30
|
||||||
|
|
||||||
|
"))
|
||||||
|
(pam-services ->
|
||||||
|
;; Services known to PAM.
|
||||||
|
(list %pam-other-services
|
||||||
|
(unix-pam-service "login"
|
||||||
|
#:allow-empty-passwords? #t
|
||||||
|
#:motd motd)))
|
||||||
|
|
||||||
(build-accounts (guix-build-accounts 10 #:gid build-user-gid))
|
(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"))
|
(bash-file (package-file bash "bin/bash"))
|
||||||
(dmd-file (package-file dmd "bin/dmd"))
|
(dmd-file (package-file dmd "bin/dmd"))
|
||||||
(dmd-conf (dmd-configuration-file services))
|
(dmd-conf (dmd-configuration-file services))
|
||||||
|
|
@ -519,9 +589,7 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
|
||||||
(home-directory "/home/guest")
|
(home-directory "/home/guest")
|
||||||
(shell bash-file))
|
(shell bash-file))
|
||||||
build-accounts))
|
build-accounts))
|
||||||
(passwd (passwd-file accounts))
|
(groups -> (list (user-group
|
||||||
(shadow (passwd-file accounts #:shadow? #t))
|
|
||||||
(group (group-file (list (user-group
|
|
||||||
(name "root")
|
(name "root")
|
||||||
(id 0))
|
(id 0))
|
||||||
(user-group
|
(user-group
|
||||||
|
|
@ -532,10 +600,7 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
|
||||||
(name "guixbuild")
|
(name "guixbuild")
|
||||||
(id build-user-gid)
|
(id build-user-gid)
|
||||||
(members (map user-account-name
|
(members (map user-account-name
|
||||||
build-accounts))))))
|
build-accounts)))))
|
||||||
(pam.d-drv (pam-services->directory %pam-services))
|
|
||||||
(pam.d -> (derivation->output-path pam.d-drv))
|
|
||||||
|
|
||||||
(packages -> `(("coreutils" ,coreutils)
|
(packages -> `(("coreutils" ,coreutils)
|
||||||
("bash" ,bash)
|
("bash" ,bash)
|
||||||
("guile" ,guile-2.0)
|
("guile" ,guile-2.0)
|
||||||
|
|
@ -552,46 +617,34 @@ Happy birthday, GNU! http://www.gnu.org/gnu30
|
||||||
("guix" ,guix)))
|
("guix" ,guix)))
|
||||||
|
|
||||||
;; TODO: Replace with a real profile with a manifest.
|
;; TODO: Replace with a real profile with a manifest.
|
||||||
;; TODO: Generate bashrc from packages' search-paths.
|
|
||||||
(profile-drv (union packages
|
(profile-drv (union packages
|
||||||
#:name "default-profile"))
|
#:name "default-profile"))
|
||||||
(profile -> (derivation->output-path profile-drv))
|
(profile -> (derivation->output-path profile-drv))
|
||||||
(bashrc (text-file "bashrc" (string-append "
|
(etc-drv (etc-directory #:accounts accounts #:groups groups
|
||||||
export PS1='\\u@\\h\\$ '
|
#:pam-services pam-services
|
||||||
export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin
|
#:profile profile))
|
||||||
export CPATH=$HOME/.guix-profile/include:" profile "/include
|
(etc -> (derivation->output-path etc-drv))
|
||||||
export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
|
|
||||||
alias ls='ls -p --color'
|
|
||||||
alias ll='ls -l'
|
|
||||||
")))
|
|
||||||
|
|
||||||
(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)
|
(populate -> `((directory "/nix/store" 0 ,build-user-gid)
|
||||||
(directory "/etc")
|
(directory "/etc")
|
||||||
(directory "/var/log") ; for dmd
|
(directory "/var/log") ; for dmd
|
||||||
(directory "/var/run/nscd")
|
(directory "/var/run/nscd")
|
||||||
("/etc/shadow" -> ,shadow)
|
("/etc/static" -> ,etc)
|
||||||
("/etc/passwd" -> ,passwd)
|
("/etc/shadow" -> "/etc/static/shadow")
|
||||||
("/etc/group" -> ,group)
|
("/etc/passwd" -> "/etc/static/passwd")
|
||||||
("/etc/login.defs" -> "/dev/null")
|
("/etc/group" -> "/etc/static/group")
|
||||||
("/etc/pam.d" -> ,pam.d)
|
("/etc/login.defs" -> "/etc/static/login.defs")
|
||||||
("/etc/resolv.conf" -> ,resolv.conf)
|
("/etc/pam.d" -> "/etc/static/pam.d")
|
||||||
("/etc/profile" -> ,bashrc)
|
("/etc/resolv.conf" -> "/etc/static/resolv.conf")
|
||||||
("/etc/issue" -> ,issue)
|
("/etc/profile" -> "/etc/static/profile")
|
||||||
("/etc/services" -> ,etc-services)
|
("/etc/issue" -> "/etc/static/issue")
|
||||||
("/etc/protocols" -> ,etc-protocols)
|
("/etc/services" -> "/etc/static/services")
|
||||||
("/etc/rpc" -> ,etc-rpc)
|
("/etc/protocols" -> "/etc/static/protocols")
|
||||||
|
("/etc/rpc" -> "/etc/static/rpc")
|
||||||
(directory "/var/nix/gcroots")
|
(directory "/var/nix/gcroots")
|
||||||
("/var/nix/gcroots/default-profile" -> ,profile)
|
("/var/nix/gcroots/default-profile" -> ,profile)
|
||||||
|
("/var/nix/gcroots/etc-directory" -> ,etc)
|
||||||
(directory "/tmp")
|
(directory "/tmp")
|
||||||
(directory "/var/nix/profiles/per-user/root" 0 0)
|
(directory "/var/nix/profiles/per-user/root" 0 0)
|
||||||
(directory "/var/nix/profiles/per-user/guest"
|
(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)
|
#:inputs-to-copy `(("boot" ,boot)
|
||||||
("linux" ,linux-libre)
|
("linux" ,linux-libre)
|
||||||
("initrd" ,gnu-system-initrd)
|
("initrd" ,gnu-system-initrd)
|
||||||
("pam.d" ,pam.d-drv)
|
|
||||||
("profile" ,profile-drv)
|
|
||||||
|
|
||||||
;; Configuration.
|
|
||||||
("dmd.conf" ,dmd-conf)
|
("dmd.conf" ,dmd-conf)
|
||||||
("etc-pam.d" ,pam.d-drv)
|
("profile" ,profile-drv)
|
||||||
("etc-passwd" ,passwd)
|
("etc" ,etc-drv)
|
||||||
("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
|
,@(append-map service-inputs
|
||||||
services)))))
|
services)))))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue