X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/fbb3555809966ee2dacfe16451fba0b963d1cdc0..5d4bd2ee94075a1c9abb12d16c62edddf9bb006c:/gnu/build/linux-initrd.scm diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm index 8caeba8722..bb2ed0db0c 100644 --- a/gnu/build/linux-initrd.scm +++ b/gnu/build/linux-initrd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2018, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,9 +17,15 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build linux-initrd) - #:use-module (ice-9 popen) + #:use-module ((guix cpio) #:prefix cpio:) + #: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 ftw) - #:export (write-cpio-archive)) + #:export (write-cpio-archive + build-initrd)) ;;; Commentary: ;;; @@ -32,39 +38,119 @@ (define* (write-cpio-archive output directory #:key (compress? #t) - (cpio "cpio") (gzip "gzip")) - "Write a cpio archive containing DIRECTORY to file OUTPUT, using CPIO. When -COMPRESS? is true, compress it using GZIP. On success, return OUTPUT." - (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" "-O" output - "-H" "newc" "--null" - "--no-absolute-filenames"))) - (define (print0 file) - (format pipe "~a\0" file)) - - ;; Note: as per `ramfs-rootfs-initramfs.txt', always add directory entries - ;; before the files that are inside of it: "The Linux kernel cpio - ;; extractor won't create files in a directory that doesn't exist, so the - ;; directory entries must go before the files that go in those - ;; directories." - - ;; XXX: Use a deterministic order. - (file-system-fold (const #t) - (lambda (file stat result) ; leaf - (print0 file)) - (lambda (dir stat result) ; down - (unless (string=? dir directory) - (print0 dir))) - (const #f) ; up - (const #f) ; skip - (const #f) - #f - directory) - - (and (zero? (close-pipe pipe)) - (or (not compress?) - (and (zero? (system* gzip "--best" output)) - (rename-file (string-append output ".gz") - output)) - output)))) + (gzip "gzip")) + "Write a cpio archive containing DIRECTORY to file OUTPUT, with reset +timestamps in the archive. When COMPRESS? is true, compress it using GZIP. +On success, return OUTPUT." + + ;; Note: as per `ramfs-rootfs-initramfs.txt', always add directory entries + ;; before the files that are inside of it: "The Linux kernel cpio + ;; extractor won't create files in a directory that doesn't exist, so the + ;; directory entries must go before the files that go in those + ;; directories." + + (define files + ;; Use 'sort' so that (1) the order of files is deterministic, and (2) + ;; directories appear before the files they contain. + (sort (file-system-fold (const #t) ;enter? + (lambda (file stat result) ;leaf + (cons file result)) + (lambda (dir stat result) ;down + (if (string=? dir directory) + result + (cons dir result))) + (lambda (file stat result) + result) + (const #f) ;skip + (const #f) ;error + '() + directory) + stringheader cpio:file->cpio-header*))) + + (if compress? + ;; Gzip insists on adding a '.gz' suffix and does nothing if the input + ;; file already has that suffix. Shuffle files around to placate it. + (let* ((gz-suffix? (string-suffix? ".gz" output)) + (sans-gz (if gz-suffix? + (string-drop-right output 3) + output))) + (when gz-suffix? + (rename-file output sans-gz)) + ;; Use '--no-name' so that gzip records neither a file name nor a time + ;; stamp in its output. + (and (zero? (system* gzip "--best" "--no-name" sans-gz)) + (begin + (unless gz-suffix? + (rename-file (string-append output ".gz") 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 '()) + (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" + #:deduplicate? #f) + + (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") + + (write-cpio-archive output "." #:gzip gzip)) + + ;; Make sure directories are writable so we can delete files. + (for-each make-file-writable + (find-files "contents" + (lambda (file stat) + (eq? 'directory (stat:type stat))) + #:directories? #t)) + (delete-file-recursively "contents")) ;;; linux-initrd.scm ends here