Merge branch 'master' into core-updates

Conflicts:
	gnu/packages/image.scm

4 files changed, 163 insertions, 51 deletions

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 362669cbf9..04dd19f3e1 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -26,6 +26,7 @@
   #:export (activate-users+groups
             activate-etc
             activate-setuid-programs
+            activate-/bin/sh
             activate-current-system))
 
 ;;; Commentary:
@@ -146,48 +147,64 @@ numeric gid or #f."
   ;; /etc is a mixture of static and dynamic settings.  Here is where we
   ;; initialize it from the static part.
 
+  (define (rm-f file)
+    (false-if-exception (delete-file file)))
+
   (format #t "populating /etc from ~a...~%" etc)
-  (let ((rm-f (lambda (f)
-                (false-if-exception (delete-file f)))))
-    (rm-f "/etc/static")
-    (symlink etc "/etc/static")
-    (for-each (lambda (file)
-                ;; TODO: Handle 'shadow' specially so that changed
-                ;; password aren't lost.
-                (let ((target (string-append "/etc/" file))
-                      (source (string-append "/etc/static/" file)))
-                  (rm-f target)
-                  (symlink source target)))
-              (scandir etc
-                       (lambda (file)
-                         (not (member file '("." ".."))))
-
-                       ;; The default is 'string-locale<?', but we don't have
-                       ;; it when run from the initrd's statically-linked
-                       ;; Guile.
-                       string<?))
-
-    ;; Prevent ETC from being GC'd.
-    (rm-f "/var/guix/gcroots/etc-directory")
-    (symlink etc "/var/guix/gcroots/etc-directory")))
+
+  (rm-f "/etc/static")
+  (symlink etc "/etc/static")
+  (for-each (lambda (file)
+              (let ((target (string-append "/etc/" file))
+                    (source (string-append "/etc/static/" file)))
+                (rm-f target)
+
+                ;; Things such as /etc/sudoers must be regular files, not
+                ;; symlinks; furthermore, they could be modified behind our
+                ;; back---e.g., with 'visudo'.  Thus, make a copy instead of
+                ;; symlinking them.
+                (if (file-is-directory? source)
+                    (symlink source target)
+                    (copy-file source target))
+
+                ;; XXX: Dirty hack to meet sudo's expectations.
+                (when (string=? (basename target) "sudoers")
+                  (chmod target #o440))))
+            (scandir etc
+                     (lambda (file)
+                       (not (member file '("." ".."))))
+
+                     ;; The default is 'string-locale<?', but we don't have
+                     ;; it when run from the initrd's statically-linked
+                     ;; Guile.
+                     string<?))
+
+  ;; Prevent ETC from being GC'd.
+  (rm-f "/var/guix/gcroots/etc-directory")
+  (symlink etc "/var/guix/gcroots/etc-directory"))
 
 (define %setuid-directory
   ;; Place where setuid programs are stored.
   "/run/setuid-programs")
 
+(define (link-or-copy source target)
+  "Attempt to make TARGET a hard link to SOURCE; if it fails, fall back to
+copy SOURCE to TARGET."
+  (catch 'system-error
+    (lambda ()
+      (link source target))
+    (lambda args
+      ;; Perhaps SOURCE and TARGET live in a different file system, so copy
+      ;; SOURCE.
+      (copy-file source target))))
+
 (define (activate-setuid-programs programs)
   "Turn PROGRAMS, a list of file names, into setuid programs stored under
 %SETUID-DIRECTORY."
   (define (make-setuid-program prog)
     (let ((target (string-append %setuid-directory
                                  "/" (basename prog))))
-      (catch 'system-error
-        (lambda ()
-          (link prog target))
-        (lambda args
-          ;; Perhaps PROG and TARGET live in a different file system, so copy
-          ;; PROG.
-          (copy-file prog target)))
+      (link-or-copy prog target)
       (chown target 0 0)
       (chmod target #o6555)))
 
@@ -204,6 +221,11 @@ numeric gid or #f."
 
   (for-each make-setuid-program programs))
 
+(define (activate-/bin/sh shell)
+  "Change /bin/sh to point to SHELL."
+  (symlink shell "/bin/sh.new")
+  (rename-file "/bin/sh.new" "/bin/sh"))
+
 (define %current-system
   ;; The system that is current (a symlink.)  This is not necessarily the same
   ;; as the system we booted (aka. /run/booted-system) because we can re-build
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index e16896f8b8..a472259a4a 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -56,18 +56,38 @@ MOUNT-POINT."
   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
 directory TARGET."
   (let loop ((directive directive))
-    (match directive
-      (('directory name)
-       (mkdir-p (string-append target name)))
-      (('directory name uid gid)
-       (let ((dir (string-append target name)))
-         (mkdir-p dir)
-         (chown dir uid gid)))
-      (('directory name uid gid mode)
-       (loop `(directory ,name ,uid ,gid))
-       (chmod (string-append target name) mode))
-      ((new '-> old)
-       (symlink old (string-append target new))))))
+    (catch 'system-error
+      (lambda ()
+        (match directive
+          (('directory name)
+           (mkdir-p (string-append target name)))
+          (('directory name uid gid)
+           (let ((dir (string-append target name)))
+             (mkdir-p dir)
+             (chown dir uid gid)))
+          (('directory name uid gid mode)
+           (loop `(directory ,name ,uid ,gid))
+           (chmod (string-append target name) mode))
+          ((new '-> old)
+           (let try ()
+             (catch 'system-error
+               (lambda ()
+                 (symlink old (string-append target new)))
+               (lambda args
+                 ;; When doing 'guix system init' on the current '/', some
+                 ;; symlinks may already exists.  Override them.
+                 (if (= EEXIST (system-error-errno args))
+                     (begin
+                       (delete-file (string-append target new))
+                       (try))
+                     (apply throw args))))))))
+      (lambda args
+        ;; Usually we can only get here when installing to an existing root,
+        ;; as with 'guix system init foo.scm /'.
+        (format (current-error-port)
+                "error: failed to evaluate directive: ~s~%"
+                directive)
+        (apply throw args)))))
 
 (define (directives store)
   "Return a list of directives to populate the root file system that will host
@@ -93,7 +113,6 @@ STORE."
     ("/var/guix/gcroots/current-system" -> "/run/current-system")
 
     (directory "/bin")
-    ("/bin/sh" -> "/run/current-system/profile/bin/bash")
     (directory "/tmp" 0 0 #o1777)                 ; sticky bit
 
     (directory "/root" 0 0)                       ; an exception
@@ -106,6 +125,7 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
             (directives (%store-directory)))
 
   ;; Add system generation 1.
+  (false-if-exception (delete-file "/var/guix/profiles/system-1-link"))
   (symlink system
            (string-append target "/var/guix/profiles/system-1-link")))
 
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 21ee58ad50..fbc683c798 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -221,6 +221,7 @@ networking values.)  Return #t if INTERFACE is up, #f otherwise."
 (define (load-linux-module* file)
   "Load Linux module from FILE, the name of a `.ko' file."
   (define (slurp module)
+    ;; TODO: Use 'mmap' to reduce memory usage.
     (call-with-input-file file get-bytevector-all))
 
   (load-linux-module (slurp file)))
@@ -342,10 +343,11 @@ bailing out.~%root contents: ~s~%" (scandir "/"))
                       volatile-root?
                       (mounts '()))
   "This procedure is meant to be called from an initrd.  Boot a system by
-first loading LINUX-MODULES, then setting up QEMU guest networking if
-QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS,
-and finally booting into the new root if any.  The initrd supports kernel
-command-line options '--load', '--root', and '--repl'.
+first loading LINUX-MODULES (a list of absolute file names of '.ko' files),
+then setting up QEMU guest networking if QEMU-GUEST-NETWORKING? is true,
+mounting the file systems specified in MOUNTS, and finally booting into the
+new root if any.  The initrd supports kernel command-line options '--load',
+'--root', and '--repl'.
 
 Mount the root file system, specified by the '--root' command-line argument,
 if any.
@@ -383,9 +385,7 @@ to it are lost."
          (start-repl))
 
        (display "loading kernel modules...\n")
-       (for-each (compose load-linux-module*
-                          (cut string-append "/modules/" <>))
-                 linux-modules)
+       (for-each load-linux-module* linux-modules)
 
        (when qemu-guest-networking?
          (unless (configure-qemu-networking)
diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm
index bf60137e8f..54639bd319 100644
--- a/gnu/build/linux-initrd.scm
+++ b/gnu/build/linux-initrd.scm
@@ -17,9 +17,15 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build linux-initrd)
+  #:use-module (guix build utils)
+  #:use-module (guix build store-copy)
+  #:use-module (system base compile)
+  #:use-module (rnrs bytevectors)
+  #:use-module ((system foreign) #:select (sizeof))
   #:use-module (ice-9 popen)
   #:use-module (ice-9 ftw)
-  #:export (write-cpio-archive))
+  #:export (write-cpio-archive
+            build-initrd))
 
 ;;; Commentary:
 ;;;
@@ -69,4 +75,68 @@ COMPRESS? is true, compress it using GZIP.  On success, return OUTPUT."
                                output))
              output))))
 
+(define (cache-compiled-file-name file)
+  "Return the file name of the in-cache .go file for FILE, relative to the
+current directory.
+
+This is similar to what 'compiled-file-name' in (system base compile) does."
+  (let loop ((file file))
+    (let ((target (false-if-exception (readlink file))))
+     (if target
+         (loop target)
+         (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a"
+                 (effective-version)
+                 (if (eq? (native-endianness) (endianness little))
+                     "LE"
+                     "BE")
+                 (sizeof '*)
+                 (effective-version)
+                 file)))))
+
+(define (compile-to-cache file)
+  "Compile FILE to the cache."
+  (let ((compiled-file (cache-compiled-file-name file)))
+    (mkdir-p (dirname compiled-file))
+    (compile-file file
+                  #:opts %auto-compilation-options
+                  #:output-file compiled-file)))
+
+(define* (build-initrd output
+                       #:key
+                       guile init
+                       (references-graphs '())
+                       (cpio "cpio")
+                       (gzip "gzip"))
+  "Write an initial RAM disk (initrd) to OUTPUT.  The initrd starts the script
+at INIT, running GUILE.  It contains all the items referred to by
+REFERENCES-GRAPHS."
+  (mkdir "contents")
+
+  ;; Copy the closures of all the items referenced in REFERENCES-GRAPHS.
+  (populate-store references-graphs "contents")
+
+  (with-directory-excursion "contents"
+    ;; Make '/init'.
+    (symlink init "init")
+
+    ;; Compile it.
+    (compile-to-cache "init")
+
+    ;; Allow Guile to find out where it is (XXX).  See
+    ;; 'guile-relocatable.patch'.
+    (mkdir-p "proc/self")
+    (symlink (string-append guile "/bin/guile") "proc/self/exe")
+    (readlink "proc/self/exe")
+
+    ;; Reset the timestamps of all the files that will make it in the initrd.
+    (for-each (lambda (file)
+                (unless (eq? 'symlink (stat:type (lstat file)))
+                  (utime file 0 0 0 0)))
+              (find-files "." ".*"))
+
+    (write-cpio-archive output "."
+                        #:cpio cpio #:gzip gzip))
+
+  (delete-file-recursively "contents"))
+
 ;;; linux-initrd.scm ends here