ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-11 21:59:08 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
* gnu/system/vm.scm (qemu-image): Change 'populate' parameter to be a
  list of directives.
  (system-qemu-image): Adjust accordingly.
This commit is contained in:
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 @@ (define* (qemu-image store #:key
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 @@ (define (graph-from-file file)
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 @@ (define (graph-from-file file)
("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 @@ (define %dmd-services
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"