diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/activation.scm | 82 | ||||
| -rw-r--r-- | gnu/build/install.scm | 46 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 14 | ||||
| -rw-r--r-- | gnu/build/linux-initrd.scm | 72 |
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 |