Commit | Line | Data |
---|---|---|
f09d925b LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (gnu packages linux-initrd) | |
20 | #:use-module (guix utils) | |
21 | #:use-module (guix licenses) | |
22 | #:use-module (gnu packages) | |
23 | #:use-module (gnu packages cpio) | |
24 | #:use-module (gnu packages compression) | |
25 | #:use-module (gnu packages linux) | |
26 | #:use-module ((gnu packages make-bootstrap) | |
27 | #:select (%guile-static-stripped)) | |
28 | #:use-module (guix packages) | |
29 | #:use-module (guix download) | |
30 | #:use-module (guix build-system trivial)) | |
31 | ||
32 | \f | |
33 | ;;; Commentary: | |
34 | ;;; | |
35 | ;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in | |
36 | ;;; particular initrd's that run Guile. | |
37 | ;;; | |
38 | ;;; Code: | |
39 | ||
40 | ||
41 | (define* (expression->initrd exp | |
42 | #:key | |
43 | (guile %guile-static-stripped) | |
44 | (cpio cpio) | |
45 | (gzip gzip) | |
46 | (name "guile-initrd") | |
47 | (system (%current-system)) | |
48 | (linux #f) | |
49 | (linux-modules '())) | |
50 | "Return a package that contains a Linux initrd (a gzipped cpio archive) | |
51 | containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list | |
52 | of `.ko' file names to be copied from LINUX into the initrd." | |
53 | ;; TODO: Add a `modules' parameter. | |
54 | ||
55 | ;; General Linux overview in `Documentation/early-userspace/README' and | |
56 | ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. | |
57 | ||
58 | (define builder | |
59 | `(begin | |
60 | (use-modules (guix build utils) | |
61 | (ice-9 pretty-print) | |
62 | (ice-9 popen) | |
63 | (ice-9 match) | |
64 | (ice-9 ftw) | |
65 | (srfi srfi-26) | |
66 | (system base compile) | |
67 | (rnrs bytevectors) | |
68 | ((system foreign) #:select (sizeof))) | |
69 | ||
70 | (let ((guile (assoc-ref %build-inputs "guile")) | |
71 | (cpio (string-append (assoc-ref %build-inputs "cpio") | |
72 | "/bin/cpio")) | |
73 | (gzip (string-append (assoc-ref %build-inputs "gzip") | |
74 | "/bin/gzip")) | |
75 | (out (assoc-ref %outputs "out"))) | |
76 | (mkdir out) | |
77 | (mkdir "contents") | |
78 | (with-directory-excursion "contents" | |
79 | (copy-recursively guile ".") | |
80 | (call-with-output-file "init" | |
81 | (lambda (p) | |
82 | (format p "#!/bin/guile -ds~%!#~%" guile) | |
83 | (pretty-print ',exp p))) | |
84 | (chmod "init" #o555) | |
85 | (chmod "bin/guile" #o555) | |
86 | ||
87 | ;; Compile `init'. | |
88 | (let ((go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" | |
89 | (effective-version) | |
90 | (if (eq? (native-endianness) (endianness little)) | |
91 | "LE" | |
92 | "BE") | |
93 | (sizeof '*) | |
94 | (effective-version)))) | |
95 | (mkdir-p go-dir) | |
96 | (compile-file "init" | |
97 | #:opts %auto-compilation-options | |
98 | #:output-file (string-append go-dir "/init.go"))) | |
99 | ||
100 | (let* ((linux (assoc-ref %build-inputs "linux")) | |
101 | (module-dir (and linux | |
102 | (string-append linux "/lib/modules")))) | |
103 | (mkdir "modules") | |
104 | ,@(map (lambda (module) | |
105 | `(match (find-files module-dir ,module) | |
106 | ((file) | |
107 | (format #t "copying '~a'...~%" file) | |
108 | (copy-file file (string-append "modules/" | |
109 | ,module))) | |
110 | (() | |
111 | (error "module not found" ,module module-dir)) | |
112 | ((_ ...) | |
113 | (error "several modules by that name" | |
114 | ,module module-dir)))) | |
115 | linux-modules)) | |
116 | ||
117 | ;; Reset the timestamps of all the files that will make it in the | |
118 | ;; initrd. | |
119 | (for-each (cut utime <> 0 0 0 0) | |
120 | (find-files "." ".*")) | |
121 | ||
122 | (system* cpio "--version") | |
123 | (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" | |
124 | "-O" (string-append out "/initrd") | |
125 | "-H" "newc" "--null"))) | |
126 | (define print0 | |
127 | (let ((len (string-length "./"))) | |
128 | (lambda (file) | |
129 | (format pipe "~a\0" (string-drop file len))))) | |
130 | ||
131 | ;; Note: as per `ramfs-rootfs-initramfs.txt', always add | |
132 | ;; directory entries before the files that are inside of it: "The | |
133 | ;; Linux kernel cpio extractor won't create files in a directory | |
134 | ;; that doesn't exist, so the directory entries must go before | |
135 | ;; the files that go in those directories." | |
136 | (file-system-fold (const #t) | |
137 | (lambda (file stat result) ; leaf | |
138 | (print0 file)) | |
139 | (lambda (dir stat result) ; down | |
140 | (unless (string=? dir ".") | |
141 | (print0 dir))) | |
142 | (const #f) ; up | |
143 | (const #f) ; skip | |
144 | (const #f) | |
145 | #f | |
146 | ".") | |
147 | ||
148 | (and (zero? (close-pipe pipe)) | |
149 | (with-directory-excursion out | |
150 | (and (zero? (system* gzip "--best" "initrd")) | |
151 | (rename-file "initrd.gz" "initrd"))))))))) | |
152 | ||
153 | (let ((name* name)) | |
154 | (package | |
155 | (name name*) | |
156 | (version "0") | |
157 | (source #f) | |
158 | (build-system trivial-build-system) | |
159 | (arguments `(#:modules ((guix build utils)) | |
160 | #:builder ,builder)) | |
161 | (inputs `(("guile" ,guile) | |
162 | ("cpio" ,cpio) | |
163 | ("gzip" ,gzip) | |
164 | ,@(if linux | |
165 | `(("linux" ,linux)) | |
166 | '()))) | |
167 | (synopsis "An initial RAM disk (initrd) for the Linux kernel") | |
168 | (description | |
169 | "An initial RAM disk (initrd), really a gzipped cpio archive, for use by | |
170 | the Linux kernel.") | |
171 | (license gpl3+) | |
172 | (home-page "http://www.gnu.org/software/guix/")))) | |
173 | ||
174 | (define-public qemu-initrd | |
175 | (expression->initrd | |
176 | '(begin | |
177 | (use-modules (rnrs io ports) | |
178 | (srfi srfi-1) | |
179 | (srfi srfi-26) | |
180 | (ice-9 match) | |
181 | ((system foreign) #:select (string->pointer)) | |
182 | ((system base compile) #:select (compile-file))) | |
183 | ||
184 | (display "Welcome, this is GNU/Guile!\n") | |
185 | (display "Use '--repl' for an initrd REPL.\n\n") | |
186 | ||
187 | (mkdir "/proc") | |
188 | (mount "none" "/proc" "proc") | |
189 | ||
190 | (mkdir "/sys") | |
191 | (mount "none" "/sys" "sysfs") | |
192 | ||
193 | (let* ((command (string-trim-both | |
194 | (call-with-input-file "/proc/cmdline" | |
195 | get-string-all))) | |
196 | (args (string-split command char-set:blank)) | |
197 | (option (lambda (opt) | |
198 | (let ((opt (string-append opt "="))) | |
199 | (and=> (find (cut string-prefix? opt <>) | |
200 | args) | |
201 | (lambda (arg) | |
202 | (substring arg (+ 1 (string-index arg #\=)))))))) | |
203 | (to-load (option "--load")) | |
204 | (root (option "--root"))) | |
205 | ||
206 | (when (member "--repl" args) | |
207 | ((@ (system repl repl) start-repl))) | |
208 | ||
209 | (let ((slurp (lambda (module) | |
210 | (call-with-input-file | |
211 | (string-append "/modules/" module) | |
212 | get-bytevector-all)))) | |
213 | (display "loading CIFS and companion modules...\n") | |
214 | (for-each (compose load-linux-module slurp) | |
215 | (list "md4.ko" "ecb.ko" "cifs.ko"))) | |
216 | ||
217 | ;; See net/slirp.c for default QEMU networking values. | |
218 | (display "configuring network...\n") | |
219 | (let* ((sock (socket AF_INET SOCK_STREAM 0)) | |
220 | (address (make-socket-address AF_INET | |
221 | (inet-pton AF_INET | |
222 | "10.0.2.10") | |
223 | 0)) | |
224 | (flags (network-interface-flags sock "eth0"))) | |
225 | (set-network-interface-address sock "eth0" address) | |
226 | (set-network-interface-flags sock "eth0" | |
227 | (logior flags IFF_UP)) | |
228 | (if (logand (network-interface-flags sock "eth0") IFF_UP) | |
229 | (display "network interface is up\n") | |
230 | (display "network interface is DOWN\n")) | |
231 | ||
232 | (mkdir "/etc") | |
233 | (call-with-output-file "/etc/resolv.conf" | |
234 | (lambda (p) | |
235 | (display "nameserver 10.0.2.3\n" p))) | |
236 | (sleep 1)) | |
237 | ||
238 | ;; Prepare the real root file system under /root. | |
239 | (unless (file-exists? "/root") | |
240 | (mkdir "/root")) | |
241 | (if root | |
242 | (mount root "/root" "ext3") | |
243 | (mount "none" "/root" "tmpfs")) | |
244 | (mkdir "/root/proc") | |
245 | (mount "none" "/root/proc" "proc") | |
246 | (mkdir "/root/sys") | |
247 | (mount "none" "/root/sys" "sysfs") | |
248 | (mkdir "/root/xchg") | |
249 | (mkdir "/root/nix") | |
250 | (mkdir "/root/nix/store") | |
251 | ||
252 | (mkdir "/root/dev") | |
253 | (let ((makedev (lambda (major minor) | |
254 | (+ (* major 256) minor)))) | |
255 | (mknod "/root/dev/null" 'char-special #o666 (makedev 1 3)) | |
256 | (mknod "/root/dev/zero" 'char-special #o666 (makedev 1 5))) | |
257 | ||
258 | ;; Mount the host's store and exchange directory. | |
259 | (display "mounting QEMU's SMB shares...\n") | |
260 | (let ((server "10.0.2.4")) | |
261 | (mount (string-append "//" server "/store") "/root/nix/store" "cifs" 0 | |
262 | (string->pointer "guest,sec=none")) | |
263 | (mount (string-append "//" server "/xchg") "/root/xchg" "cifs" 0 | |
264 | (string->pointer "guest,sec=none"))) | |
265 | ||
266 | (if to-load | |
267 | (begin | |
268 | (format #t "loading boot file '~a'...\n" to-load) | |
269 | (compile-file (string-append "/root/" to-load) | |
270 | #:output-file "/root/loader.go" | |
271 | #:opts %auto-compilation-options) | |
272 | (match (primitive-fork) | |
273 | (0 | |
274 | (chroot "/root") | |
275 | (load-compiled "/loader.go")) | |
276 | (pid | |
277 | (format #t "boot file loaded under PID ~a~%" pid) | |
278 | (let ((status (waitpid pid))) | |
279 | (reboot))))) | |
280 | (begin | |
281 | (display "no boot file passed via '--load'\n") | |
282 | (display "entering a warm and cozy REPL\n") | |
283 | ((@ (system repl repl) start-repl)))))) | |
284 | #:name "qemu-initrd" | |
285 | #:linux linux-libre | |
286 | #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko"))) | |
287 | ||
288 | ;;; linux-initrd.scm ends here |