-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-(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))
-
-\f
-;;; 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 <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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))
+
+\f
+;;; 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
+ (($ <file-system> 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
HCoop / jackhill / guix / guix.git / blobdiff