nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

gnu: vm: Change #:populate to a list of directives. 

* gnu/system/vm.scm (qemu-image): Change 'populate' parameter to be a
  list of directives.
  (system-qemu-image): Adjust accordingly.
master
Ludovic Courtès 2013-09-25 18:01:44 +02:00
parent 25eb16bf3b
commit d5d0f286a2
1 changed files with 28 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
gnu/system/vm.scm
View File

@ -211,9 +211,10 @@ INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
into the image being built. When INITIALIZE-STORE? is true, initialize the 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. 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 POPULATE is a list of directives stating directories or symlinks to be created
in the disk image partition once it has been populated with INPUTS-TO-COPY. in the disk image partition. It is evaluated once the image has been
It can be used to provide additional files, such as /etc files." populated with INPUTS-TO-COPY. It can be used to provide additional files,
such as /etc files."
(define input->name+derivation (define input->name+derivation
(match-lambda (match-lambda
((name (? package? package)) ((name (? package? package))
@ -326,6 +327,22 @@ It can be used to provide additional files, such as /etc files."
graph-files))) graph-files)))
'(#f))) '(#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") (and=> (assoc-ref %build-inputs "populate")
(lambda (populate) (lambda (populate)
(chdir "/fs") (chdir "/fs")
@ -365,9 +382,6 @@ It can be used to provide additional files, such as /etc files."
("gawk" ,(car (assoc-ref %final-inputs "gawk"))) ("gawk" ,(car (assoc-ref %final-inputs "gawk")))
("util-linux" ,util-linux) ("util-linux" ,util-linux)
,@(if populate
`(("populate" ,populate))
'())
,@(if initialize-store? ,@(if initialize-store?
`(("guix" ,guix-0.4)) `(("guix" ,guix-0.4))
'()) '())
@ -473,21 +487,14 @@ alias ls='ls -p --color'
alias ll='ls -l' alias ll='ls -l'
"))) ")))
(populate (populate `((directory "/etc")
(add-text-to-store store "populate-qemu-image" (directory "/var/log")
(object->string (directory "/var/run")
`(begin ("/etc/shadow" -> ,shadow)
(mkdir-p "etc") ("/etc/passwd" -> ,passwd)
(mkdir-p "var/log") ; for dmd ("/etc/login.defs" -> "/dev/null")
(symlink ,shadow "etc/shadow") ("/etc/pam.d" -> ,pam.d)
(symlink ,passwd "etc/passwd") ("/etc/profile" -> ,bashrc)))
(symlink ,group "etc/group")
(symlink "/dev/null"
"etc/login.defs")
(symlink ,pam.d "etc/pam.d")
(symlink ,bashrc "etc/profile")
(mkdir-p "var/run")))
(list passwd)))
(out (derivation->output-path (out (derivation->output-path
(package-derivation store mingetty))) (package-derivation store mingetty)))
(boot (add-text-to-store store "boot" (boot (add-text-to-store store "boot"