Ludovic Courtès
10 years ago
2 changed files with 289 additions and 0 deletions
@ -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 |
|||
Loading…
Reference in new issue