From f09d925b1632d5a8dd0999651dab6424847deeea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 16 Feb 2013 03:25:59 +0100 Subject: gnu: Add support for Guile in Linux initrd. * gnu/packages/linux-initrd.scm: New file. --- Makefile.am | 1 + gnu/packages/linux-initrd.scm | 288 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 289 insertions(+) create mode 100644 gnu/packages/linux-initrd.scm diff --git a/Makefile.am b/Makefile.am index c9e3ca92f5..f81516c227 100644 --- a/Makefile.am +++ b/Makefile.am @@ -107,6 +107,7 @@ MODULES = \ gnu/packages/libusb.scm \ gnu/packages/libunwind.scm \ gnu/packages/linux.scm \ + gnu/packages/linux-initrd.scm \ gnu/packages/lout.scm \ gnu/packages/lsh.scm \ gnu/packages/m4.scm \ diff --git a/gnu/packages/linux-initrd.scm b/gnu/packages/linux-initrd.scm new file mode 100644 index 0000000000..348e411d07 --- /dev/null +++ b/gnu/packages/linux-initrd.scm @@ -0,0 +1,288 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 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 packages linux-initrd) + #:use-module (guix utils) + #:use-module (guix licenses) + #:use-module (gnu packages) + #:use-module (gnu packages cpio) + #:use-module (gnu packages compression) + #:use-module (gnu packages linux) + #:use-module ((gnu packages make-bootstrap) + #:select (%guile-static-stripped)) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build-system trivial)) + + +;;; 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)) + (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." + ;; TODO: Add a `modules' parameter. + + ;; General Linux overview in `Documentation/early-userspace/README' and + ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. + + (define builder + `(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")) + (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) + + ;; Compile `init'. + (let ((go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" + (effective-version) + (if (eq? (native-endianness) (endianness little)) + "LE" + "BE") + (sizeof '*) + (effective-version)))) + (mkdir-p go-dir) + (compile-file "init" + #:opts %auto-compilation-options + #:output-file (string-append go-dir "/init.go"))) + + (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 ,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)) + + ;; 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"))))))))) + + (let ((name* name)) + (package + (name name*) + (version "0") + (source #f) + (build-system trivial-build-system) + (arguments `(#:modules ((guix build utils)) + #:builder ,builder)) + (inputs `(("guile" ,guile) + ("cpio" ,cpio) + ("gzip" ,gzip) + ,@(if linux + `(("linux" ,linux)) + '()))) + (synopsis "An initial RAM disk (initrd) for the Linux kernel") + (description + "An initial RAM disk (initrd), really a gzipped cpio archive, for use by +the Linux kernel.") + (license gpl3+) + (home-page "http://www.gnu.org/software/guix/")))) + +(define-public qemu-initrd + (expression->initrd + '(begin + (use-modules (rnrs io ports) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match) + ((system foreign) #:select (string->pointer)) + ((system base compile) #:select (compile-file))) + + (display "Welcome, this is GNU/Guile!\n") + (display "Use '--repl' for an initrd REPL.\n\n") + + (mkdir "/proc") + (mount "none" "/proc" "proc") + + (mkdir "/sys") + (mount "none" "/sys" "sysfs") + + (let* ((command (string-trim-both + (call-with-input-file "/proc/cmdline" + get-string-all))) + (args (string-split command char-set:blank)) + (option (lambda (opt) + (let ((opt (string-append opt "="))) + (and=> (find (cut string-prefix? opt <>) + args) + (lambda (arg) + (substring arg (+ 1 (string-index arg #\=)))))))) + (to-load (option "--load")) + (root (option "--root"))) + + (when (member "--repl" args) + ((@ (system repl repl) start-repl))) + + (let ((slurp (lambda (module) + (call-with-input-file + (string-append "/modules/" module) + get-bytevector-all)))) + (display "loading CIFS and companion modules...\n") + (for-each (compose load-linux-module slurp) + (list "md4.ko" "ecb.ko" "cifs.ko"))) + + ;; See net/slirp.c for default QEMU networking values. + (display "configuring network...\n") + (let* ((sock (socket AF_INET SOCK_STREAM 0)) + (address (make-socket-address AF_INET + (inet-pton AF_INET + "10.0.2.10") + 0)) + (flags (network-interface-flags sock "eth0"))) + (set-network-interface-address sock "eth0" address) + (set-network-interface-flags sock "eth0" + (logior flags IFF_UP)) + (if (logand (network-interface-flags sock "eth0") IFF_UP) + (display "network interface is up\n") + (display "network interface is DOWN\n")) + + (mkdir "/etc") + (call-with-output-file "/etc/resolv.conf" + (lambda (p) + (display "nameserver 10.0.2.3\n" p))) + (sleep 1)) + + ;; Prepare the real root file system under /root. + (unless (file-exists? "/root") + (mkdir "/root")) + (if root + (mount root "/root" "ext3") + (mount "none" "/root" "tmpfs")) + (mkdir "/root/proc") + (mount "none" "/root/proc" "proc") + (mkdir "/root/sys") + (mount "none" "/root/sys" "sysfs") + (mkdir "/root/xchg") + (mkdir "/root/nix") + (mkdir "/root/nix/store") + + (mkdir "/root/dev") + (let ((makedev (lambda (major minor) + (+ (* major 256) minor)))) + (mknod "/root/dev/null" 'char-special #o666 (makedev 1 3)) + (mknod "/root/dev/zero" 'char-special #o666 (makedev 1 5))) + + ;; Mount the host's store and exchange directory. + (display "mounting QEMU's SMB shares...\n") + (let ((server "10.0.2.4")) + (mount (string-append "//" server "/store") "/root/nix/store" "cifs" 0 + (string->pointer "guest,sec=none")) + (mount (string-append "//" server "/xchg") "/root/xchg" "cifs" 0 + (string->pointer "guest,sec=none"))) + + (if to-load + (begin + (format #t "loading boot file '~a'...\n" to-load) + (compile-file (string-append "/root/" to-load) + #:output-file "/root/loader.go" + #:opts %auto-compilation-options) + (match (primitive-fork) + (0 + (chroot "/root") + (load-compiled "/loader.go")) + (pid + (format #t "boot file loaded under PID ~a~%" pid) + (let ((status (waitpid pid))) + (reboot))))) + (begin + (display "no boot file passed via '--load'\n") + (display "entering a warm and cozy REPL\n") + ((@ (system repl repl) start-repl)))))) + #:name "qemu-initrd" + #:linux linux-libre + #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko"))) + +;;; linux-initrd.scm ends here -- cgit v1.2.3