aboutsummaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-02-16 03:25:59 +0100
committerLudovic Courtès <ludo@gnu.org>2013-02-27 20:55:40 +0100
commit3855e242a24025cc6f83731e7cf5d2ea73aeb23e (patch)
tree86a577e1a1d8173fdba0a0dccbfd6f97497b23a6 /gnu
parent106ca9d0c160137ac41466b6d7cf18eee4f4583e (diff)
downloadpatches-3855e242a24025cc6f83731e7cf5d2ea73aeb23e.tar
patches-3855e242a24025cc6f83731e7cf5d2ea73aeb23e.tar.gz
gnu: Add support for Guile in Linux initrd.
* gnu/packages/linux-initrd.scm: New file.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/packages/linux-initrd.scm288
1 files changed, 288 insertions, 0 deletions
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 <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 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