ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu: vm: Factorize /etc creation.

Browse source 
* 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 2013-12-06 23:26:51 +01:00
parent dc47b181da
commit 0b8a376b68
1 changed files with 137 additions and 95 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

232
gnu/system/vm.scm
View file

@ -59,6 +59,21 @@ (define-module (gnu system vm)
;;; ;;;
;;; 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 @@ (define builder
(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 @@ (define builder
#: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 @@ (define build-user-gid 30000)
;; 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,23 +589,18 @@ (define build-user-gid 30000)
(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)) (name "root")
(group (group-file (list (user-group (id 0))
(name "root") (user-group
(id 0)) (name "users")
(user-group (id 100)
(name "users") (members '("guest")))
(id 100) (user-group
(members '("guest"))) (name "guixbuild")
(user-group (id build-user-gid)
(name "guixbuild") (members (map user-account-name
(id build-user-gid) build-accounts)))))
(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) (packages -> `(("coreutils" ,coreutils)
("bash" ,bash) ("bash" ,bash)
("guile" ,guile-2.0) ("guile" ,guile-2.0)
@ -552,46 +617,34 @@ (define build-user-gid 30000)
("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 @@ (define build-user-gid 30000)
#: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)))))