X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/1c96c1bbabb9646aba2a3860cac02157f56c4dd1..493c245b8f464b5ad1b93caecc589a8e3cabcf0b:/gnu/system/linux-initrd.scm diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm dissimilarity index 78% index 786e068764..e66d9fe17a 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -1,286 +1,253 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu system linux-initrd) - #:use-module (guix monads) - #:use-module (guix utils) - #:use-module ((guix store) - #:select (%store-prefix)) - #:use-module ((guix derivations) - #:select (derivation->output-path)) - #:use-module (gnu packages cpio) - #:use-module (gnu packages compression) - #:use-module (gnu packages linux) - #:use-module (gnu packages guile) - #:use-module ((gnu packages make-bootstrap) - #:select (%guile-static-stripped)) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:export (expression->initrd - qemu-initrd - gnu-system-initrd)) - - -;;; Commentary: -;;; -;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in -;;; particular initrd's that run Guile. -;;; -;;; Code: - - -(define* (expression->initrd exp - #:key - (guile %guile-static-stripped) - (cpio cpio) - (gzip gzip) - (name "guile-initrd") - (system (%current-system)) - (modules '()) - (inputs '()) - (linux #f) - (linux-modules '())) - "Return a package that contains a Linux initrd (a gzipped cpio archive) -containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list -of `.ko' file names to be copied from LINUX into the initrd. INPUTS is a list -of additional inputs to be copied in the initrd. MODULES is a list of Guile -module names to be embedded in the initrd." - - ;; General Linux overview in `Documentation/early-userspace/README' and - ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. - - (define (string->regexp str) - ;; Return a regexp that matches STR exactly. - (string-append "^" (regexp-quote str) "$")) - - (define (files-to-copy) - (mlet %store-monad ((inputs (lower-inputs inputs))) - (return (map (match-lambda - ((_ drv) - (derivation->output-path drv)) - ((_ drv sub-drv) - (derivation->output-path drv sub-drv))) - inputs)))) - - (define (builder to-copy) - `(begin - (use-modules (guix build utils) - (ice-9 pretty-print) - (ice-9 popen) - (ice-9 match) - (ice-9 ftw) - (srfi srfi-26) - (system base compile) - (rnrs bytevectors) - ((system foreign) #:select (sizeof))) - - (let ((guile (assoc-ref %build-inputs "guile")) - (cpio (string-append (assoc-ref %build-inputs "cpio") - "/bin/cpio")) - (gzip (string-append (assoc-ref %build-inputs "gzip") - "/bin/gzip")) - (modules (assoc-ref %build-inputs "modules")) - (gos (assoc-ref %build-inputs "modules/compiled")) - (scm-dir (string-append "share/guile/" (effective-version))) - (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" - (effective-version) - (if (eq? (native-endianness) (endianness little)) - "LE" - "BE") - (sizeof '*) - (effective-version))) - (out (assoc-ref %outputs "out"))) - (mkdir out) - (mkdir "contents") - (with-directory-excursion "contents" - (copy-recursively guile ".") - (call-with-output-file "init" - (lambda (p) - (format p "#!/bin/guile -ds~%!#~%" guile) - (pretty-print ',exp p))) - (chmod "init" #o555) - (chmod "bin/guile" #o555) - - ;; Copy Guile modules. - (chmod scm-dir #o777) - (copy-recursively modules scm-dir - #:follow-symlinks? #t) - (copy-recursively gos (string-append "lib/guile/" - (effective-version) "/ccache") - #:follow-symlinks? #t) - - ;; Compile `init'. - (mkdir-p go-dir) - (set! %load-path (cons modules %load-path)) - (set! %load-compiled-path (cons gos %load-compiled-path)) - (compile-file "init" - #:opts %auto-compilation-options - #:output-file (string-append go-dir "/init.go")) - - ;; Copy Linux modules. - (let* ((linux (assoc-ref %build-inputs "linux")) - (module-dir (and linux - (string-append linux "/lib/modules")))) - (mkdir "modules") - ,@(map (lambda (module) - `(match (find-files module-dir - ,(string->regexp module)) - ((file) - (format #t "copying '~a'...~%" file) - (copy-file file (string-append "modules/" - ,module))) - (() - (error "module not found" ,module module-dir)) - ((_ ...) - (error "several modules by that name" - ,module module-dir)))) - linux-modules)) - - ,@(if (null? to-copy) - '() - `((let ((store ,(string-append "." (%store-prefix)))) - (mkdir-p store) - ;; XXX: Should we do export-references-graph? - (for-each (lambda (input) - (let ((target - (string-append store "/" - (basename input)))) - (copy-recursively input target))) - ',to-copy)))) - - ;; Reset the timestamps of all the files that will make it in the - ;; initrd. - (for-each (cut utime <> 0 0 0 0) - (find-files "." ".*")) - - (system* cpio "--version") - (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" - "-O" (string-append out "/initrd") - "-H" "newc" "--null"))) - (define print0 - (let ((len (string-length "./"))) - (lambda (file) - (format pipe "~a\0" (string-drop file len))))) - - ;; 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." - (file-system-fold (const #t) - (lambda (file stat result) ; leaf - (print0 file)) - (lambda (dir stat result) ; down - (unless (string=? dir ".") - (print0 dir))) - (const #f) ; up - (const #f) ; skip - (const #f) - #f - ".") - - (and (zero? (close-pipe pipe)) - (with-directory-excursion out - (and (zero? (system* gzip "--best" "initrd")) - (rename-file "initrd.gz" "initrd"))))))))) - - (mlet* %store-monad - ((source (imported-modules modules)) - (compiled (compiled-modules modules)) - (inputs (lower-inputs - `(("guile" ,guile) - ("cpio" ,cpio) - ("gzip" ,gzip) - ("modules" ,source) - ("modules/compiled" ,compiled) - ,@(if linux - `(("linux" ,linux)) - '()) - ,@inputs))) - (to-copy (files-to-copy))) - (derivation-expression name (builder to-copy) - #:modules '((guix build utils)) - #:inputs inputs))) - -(define* (qemu-initrd #:key - guile-modules-in-chroot? - volatile-root? - (mounts `((cifs "/store" ,(%store-prefix)) - (cifs "/xchg" "/xchg")))) - "Return a monadic derivation that builds an initrd for use in a QEMU guest -where the store is shared with the host. MOUNTS is a list of file systems to -be mounted atop the root file system, where each item has the form: - - (FILE-SYSTEM-TYPE SOURCE TARGET) - -When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in -the new root. This is necessary is the file specified as '--load' needs -access to these modules (which is the case if it wants to even just print an -exception and backtrace!). - -When VOLATILE-ROOT? is true, the root file system is writable but any changes -to it are lost." - (define cifs-modules - ;; Modules needed to mount CIFS file systems. - '("md4.ko" "ecb.ko" "cifs.ko")) - - (define virtio-9p-modules - ;; Modules for the 9p paravirtualized file system. - '("9pnet.ko" "9p.ko" "9pnet_virtio.ko")) - - (define linux-modules - ;; Modules added to the initrd and loaded from the initrd. - `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko" - "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko" - ,@(if (assoc-ref mounts 'cifs) - cifs-modules - '()) - ,@(if (assoc-ref mounts '9p) - virtio-9p-modules - '()) - ,@(if volatile-root? - '("fuse.ko") - '()))) - - (mlet %store-monad - ((unionfs (package-file unionfs-fuse/static "bin/unionfs"))) - (expression->initrd - `(begin - (use-modules (guix build linux-initrd)) - - (boot-system #:mounts ',mounts - #:linux-modules ',linux-modules - #:qemu-guest-networking? #t - #:guile-modules-in-chroot? ',guile-modules-in-chroot? - #:unionfs ,unionfs - #:volatile-root? ',volatile-root?)) - #:name "qemu-initrd" - #:modules '((guix build utils) - (guix build linux-initrd)) - #:linux linux-libre - #:linux-modules linux-modules - #:inputs (if volatile-root? - `(("unionfs" ,unionfs-fuse/static)) - '())))) - -(define (gnu-system-initrd) - "Initrd for the GNU system itself, with nothing QEMU-specific." - (qemu-initrd #:guile-modules-in-chroot? #f - #:mounts '())) - -;;; linux-initrd.scm ends here +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu system linux-initrd) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix gexp) + #:use-module (guix utils) + #:use-module ((guix store) + #:select (%store-prefix)) + #:use-module ((guix derivations) + #:select (derivation->output-path)) + #:use-module (gnu packages cpio) + #:use-module (gnu packages compression) + #:use-module (gnu packages linux) + #:use-module (gnu packages guile) + #:use-module ((gnu packages make-bootstrap) + #:select (%guile-static-stripped)) + #:use-module (gnu system file-systems) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (expression->initrd + base-initrd)) + + +;;; Commentary: +;;; +;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in +;;; particular initrd's that run Guile. +;;; +;;; Code: + + +(define* (expression->initrd exp + #:key + (guile %guile-static-stripped) + (cpio cpio) + (gzip gzip) + (name "guile-initrd") + (system (%current-system)) + (modules '())) + "Return a derivation that builds a Linux initrd (a gzipped cpio archive) +containing GUILE and that evaluates EXP, a G-expression, upon booting. All +the derivations referenced by EXP are automatically copied to the initrd. + +MODULES is a list of Guile module names to be embedded in the initrd." + + ;; General Linux overview in `Documentation/early-userspace/README' and + ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. + + (mlet %store-monad ((init (gexp->script "init" exp + #:modules modules + #:guile guile))) + (define builder + #~(begin + (use-modules (gnu build linux-initrd)) + + (mkdir #$output) + (build-initrd (string-append #$output "/initrd") + #:guile #$guile + #:init #$init + ;; Copy everything INIT refers to into the initrd. + #:references-graphs '("closure") + #:cpio (string-append #$cpio "/bin/cpio") + #:gzip (string-append #$gzip "/bin/gzip")))) + + (gexp->derivation name builder + #:modules '((guix build utils) + (guix build store-copy) + (gnu build linux-initrd)) + #:references-graphs `(("closure" ,init))))) + +(define (flat-linux-module-directory linux modules) + "Return a flat directory containing the Linux kernel modules listed in +MODULES and taken from LINUX." + (define build-exp + #~(begin + (use-modules (ice-9 match) (ice-9 regex) + (srfi srfi-1) + (guix build utils) + (gnu build linux-modules)) + + (define (string->regexp str) + ;; Return a regexp that matches STR exactly. + (string-append "^" (regexp-quote str) "$")) + + (define module-dir + (string-append #$linux "/lib/modules")) + + (define (lookup module) + (let ((name (ensure-dot-ko module))) + (match (find-files module-dir (string->regexp name)) + ((file) + file) + (() + (error "module not found" name module-dir)) + ((_ ...) + (error "several modules by that name" + name module-dir))))) + + (define modules + (let ((modules (map lookup '#$modules))) + (append modules + (recursive-module-dependencies modules + #:lookup-module lookup)))) + + (mkdir #$output) + (for-each (lambda (module) + (format #t "copying '~a'...~%" module) + (copy-file module + (string-append #$output "/" + (basename module)))) + (delete-duplicates modules)))) + + (gexp->derivation "linux-modules" build-exp + #:modules '((guix build utils) + (guix elf) + (gnu build linux-modules)))) + +(define (file-system->spec fs) + "Return a list corresponding to file-system FS that can be passed to the +initrd code." + (match fs + (($ device title mount-point type flags options _ check?) + (list device title mount-point type flags options check?)))) + +(define* (base-initrd file-systems + #:key + (mapped-devices '()) + qemu-networking? + virtio? + volatile-root? + (extra-modules '())) + "Return a monadic derivation that builds a generic initrd. FILE-SYSTEMS is +a list of file-systems to be mounted by the initrd, possibly in addition to +the root file system specified on the kernel command line via '--root'. +MAPPED-DEVICES is a list of device mappings to realize before FILE-SYSTEMS are +mounted. + +When QEMU-NETWORKING? is true, set up networking with the standard QEMU +parameters. When VIRTIO? is true, load additional modules so the initrd can +be used as a QEMU guest with para-virtualized I/O drivers. + +When VOLATILE-ROOT? is true, the root file system is writable but any changes +to it are lost. + +The initrd is automatically populated with all the kernel modules necessary +for FILE-SYSTEMS and for the given options. However, additional kernel +modules can be listed in EXTRA-MODULES. They will be added to the initrd, and +loaded at boot time in the order in which they appear." + (define virtio-modules + ;; Modules for Linux para-virtualized devices, for use in QEMU guests. + '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net" + "virtio_console")) + + (define cifs-modules + ;; Modules needed to mount CIFS file systems. + '("md4" "ecb" "cifs")) + + (define virtio-9p-modules + ;; Modules for the 9p paravirtualized file system. + '("9p" "9pnet_virtio")) + + (define (file-system-type-predicate type) + (lambda (fs) + (string=? (file-system-type fs) type))) + + (define linux-modules + ;; Modules added to the initrd and loaded from the initrd. + `("ahci" ;for SATA controllers + "pata_acpi" "pata_atiixp" ;for ATA controllers + "usb-storage" "uas" ;for the installation image etc. + "usbkbd" "usbhid" ;USB keyboards, for debugging + ,@(if (or virtio? qemu-networking?) + virtio-modules + '()) + ,@(if (find (file-system-type-predicate "cifs") file-systems) + cifs-modules + '()) + ,@(if (find (file-system-type-predicate "9p") file-systems) + virtio-9p-modules + '()) + ,@(if volatile-root? + '("fuse") + '()) + ,@extra-modules)) + + (define helper-packages + ;; Packages to be copied on the initrd. + `(,@(if (find (lambda (fs) + (string-prefix? "ext" (file-system-type fs))) + file-systems) + (list e2fsck/static) + '()) + ,@(if volatile-root? + (list unionfs-fuse/static) + '()))) + + (define device-mapping-commands + ;; List of gexps to open the mapped devices. + (map (lambda (md) + (let* ((source (mapped-device-source md)) + (target (mapped-device-target md)) + (type (mapped-device-type md)) + (open (mapped-device-kind-open type))) + (open source target))) + mapped-devices)) + + (mlet %store-monad ((kodir (flat-linux-module-directory linux-libre + linux-modules))) + (expression->initrd + #~(begin + (use-modules (gnu build linux-boot) + (guix build utils) + (srfi srfi-26)) + + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages))) + + (boot-system #:mounts '#$(map file-system->spec file-systems) + #:pre-mount (lambda () + (and #$@device-mapping-commands)) + #:linux-modules '#$linux-modules + #:linux-module-directory '#$kodir + #:qemu-guest-networking? #$qemu-networking? + #:volatile-root? '#$volatile-root?)) + #:name "base-initrd" + #:modules '((guix build utils) + (gnu build linux-boot) + (gnu build linux-modules) + (gnu build file-systems) + (guix elf))))) + +;;; linux-initrd.scm ends here