01/52: install: 'populate-root-file-system' can be passed extra directives.

[guix-commits]

janneke pushed a commit to branch wip-hurd-vm
in repository guix.

commit 3ead1fa437b61601f1bd293fb9a350171c82a1d4
Author: Ludovic Courtès <address@hidden>
AuthorDate: Wed Apr 1 14:59:58 2020 +0200

    install: 'populate-root-file-system' can be passed extra directives.
    
    * gnu/build/install.scm (evaluate-populate-directive): Handle 'file'
    directives.
    (populate-root-file-system): Add #:extras parameter and honor it.
---
 gnu/build/install.scm | 18 ++++++++++++++----
 1 file changed, 14 insertions(+), 4 deletions(-)

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index c0d4d44..d46b588 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2016 Chris Marusich <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -67,6 +67,13 @@ directory TARGET."
           (('directory name uid gid mode)
            (loop `(directory ,name ,uid ,gid))
            (chmod (string-append target name) mode))
+          (('file name)
+           (call-with-output-file (string-append target name)
+             (const #t)))
+          (('file name (? string? content))
+           (call-with-output-file (string-append target name)
+             (lambda (port)
+               (display content port))))
           ((new '-> old)
            (let try ()
              (catch 'system-error
@@ -119,11 +126,14 @@ STORE."
 
     (directory "/home" 0 0)))
 
-(define (populate-root-file-system system target)
+(define* (populate-root-file-system system target
+                                    #:key (extras '()))
   "Make the essential non-store files and directories on TARGET.  This
-includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
+includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
+EXTRAS is a list of directives appended to the built-in directives to populate
+TARGET."
   (for-each (cut evaluate-populate-directive <> target)
-            (directives (%store-directory)))
+            (append (directives (%store-directory)) extras))
 
   ;; Add system generation 1.
   (let ((generation-1 (string-append target