gnu: Add missing copyright line
[jackhill/guix/guix.git] / guix / build / linux-initrd.scm
CommitLineData
88840f02 1;;; GNU Guix --- Functional package management for GNU
b97c95eb 2;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
88840f02
LC
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 (guix build linux-initrd)
20 #:use-module (rnrs io ports)
21 #:use-module (system foreign)
d4254711
LC
22 #:autoload (system repl repl) (start-repl)
23 #:autoload (system base compile) (compile-file)
24 #:use-module (srfi srfi-1)
25 #:use-module (srfi srfi-26)
26 #:use-module (ice-9 match)
44ddf33e 27 #:use-module (ice-9 ftw)
d4254711 28 #:use-module (guix build utils)
88840f02
LC
29 #:export (mount-essential-file-systems
30 linux-command-line
d91712ee 31 make-essential-device-nodes
88840f02
LC
32 configure-qemu-networking
33 mount-qemu-smb-share
4919d684 34 mount-qemu-9p
89bf140b 35 bind-mount
88840f02 36 load-linux-module*
d4254711
LC
37 device-number
38 boot-system))
88840f02
LC
39
40;;; Commentary:
41;;;
42;;; Utility procedures useful in a Linux initial RAM disk (initrd). Note that
43;;; many of these use procedures not yet available in vanilla Guile (`mount',
44;;; `load-linux-module', etc.); these are provided by a Guile patch used in
45;;; the GNU distribution.
46;;;
47;;; Code:
48
49(define* (mount-essential-file-systems #:key (root "/"))
50 "Mount /proc and /sys under ROOT."
51 (define (scope dir)
52 (string-append root
53 (if (string-suffix? "/" root)
54 ""
55 "/")
56 dir))
57
58 (unless (file-exists? (scope "proc"))
59 (mkdir (scope "proc")))
60 (mount "none" (scope "proc") "proc")
61
62 (unless (file-exists? (scope "sys"))
63 (mkdir (scope "sys")))
64 (mount "none" (scope "sys") "sysfs"))
65
66(define (linux-command-line)
67 "Return the Linux kernel command line as a list of strings."
68 (string-tokenize
69 (call-with-input-file "/proc/cmdline"
70 get-string-all)))
71
d91712ee
LC
72(define* (make-essential-device-nodes #:key (root "/"))
73 "Make essential device nodes under ROOT/dev."
74 ;; The hand-made udev!
75
76 (define (scope dir)
77 (string-append root
78 (if (string-suffix? "/" root)
79 ""
80 "/")
81 dir))
82
83 (unless (file-exists? (scope "dev"))
84 (mkdir (scope "dev")))
85
fc4bc4b6
LC
86 ;; Make the device nodes for SCSI disks.
87 (mknod (scope "dev/sda") 'block-special #o644 (device-number 8 0))
88 (mknod (scope "dev/sda1") 'block-special #o644 (device-number 8 1))
89 (mknod (scope "dev/sda2") 'block-special #o644 (device-number 8 2))
90
91 ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM.
92 (mknod (scope "dev/vda") 'block-special #o644 (device-number 252 0))
93 (mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1))
94 (mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2))
d91712ee 95
c04c6ff6
LC
96 ;; Memory (used by Xorg's VESA driver.)
97 (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1))
98 (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2))
99
1c221510
LC
100 ;; Inputs (used by Xorg.)
101 (unless (file-exists? (scope "dev/input"))
102 (mkdir (scope "dev/input")))
103 (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63))
104 (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32))
105 (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64))
106
d91712ee 107 ;; TTYs.
29804e6e
LC
108 (mknod (scope "dev/tty") 'char-special #o600
109 (device-number 5 0))
289773c1 110 (chmod (scope "dev/tty") #o666)
d91712ee
LC
111 (let loop ((n 0))
112 (and (< n 50)
113 (let ((name (format #f "dev/tty~a" n)))
29804e6e 114 (mknod (scope name) 'char-special #o600
d91712ee
LC
115 (device-number 4 n))
116 (loop (+ 1 n)))))
117
c9c88118
LC
118 ;; Pseudo ttys.
119 (mknod (scope "dev/ptmx") 'char-special #o666
120 (device-number 5 2))
289773c1 121 (chmod (scope "dev/ptmx") #o666)
c9c88118 122
c865a878 123 ;; Create /dev/pts; it will be mounted later, at boot time.
c9c88118
LC
124 (unless (file-exists? (scope "dev/pts"))
125 (mkdir (scope "dev/pts")))
c9c88118 126
37c825eb
LC
127 ;; Rendez-vous point for syslogd.
128 (mknod (scope "dev/log") 'socket #o666 0)
129 (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
130
289773c1
LC
131 ;; Other useful nodes, notably relied on by guix-daemon.
132 (for-each (match-lambda
133 ((file major minor)
134 (mknod (scope file) 'char-special #o666
135 (device-number major minor))
136 (chmod (scope file) #o666)))
137 '(("dev/null" 1 3)
138 ("dev/zero" 1 5)
139 ("dev/full" 1 7)
140 ("dev/random" 1 8)
141 ("dev/urandom" 1 9)))
142
143 (symlink "/proc/self/fd" (scope "dev/fd"))
144 (symlink "/proc/self/fd/0" (scope "dev/stdin"))
145 (symlink "/proc/self/fd/1" (scope "dev/stdout"))
1c96c1bb
LC
146 (symlink "/proc/self/fd/2" (scope "dev/stderr"))
147
148 ;; File systems in user space (FUSE).
149 (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
d91712ee 150
88840f02
LC
151(define %host-qemu-ipv4-address
152 (inet-pton AF_INET "10.0.2.10"))
153
154(define* (configure-qemu-networking #:optional (interface "eth0"))
155 "Setup the INTERFACE network interface and /etc/resolv.conf according to
156QEMU's default networking settings (see net/slirp.c in QEMU for default
157networking values.) Return #t if INTERFACE is up, #f otherwise."
158 (display "configuring QEMU networking...\n")
159 (let* ((sock (socket AF_INET SOCK_STREAM 0))
160 (address (make-socket-address AF_INET %host-qemu-ipv4-address 0))
161 (flags (network-interface-flags sock interface)))
162 (set-network-interface-address sock interface address)
163 (set-network-interface-flags sock interface (logior flags IFF_UP))
164
165 (unless (file-exists? "/etc")
166 (mkdir "/etc"))
167 (call-with-output-file "/etc/resolv.conf"
168 (lambda (p)
169 (display "nameserver 10.0.2.3\n" p)))
170
171 (logand (network-interface-flags sock interface) IFF_UP)))
172
173(define (mount-qemu-smb-share share mount-point)
174 "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT.
175
176Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our
177`qemu-with-multiple-smb-shares' package exports the /xchg and /store shares
178 (the latter allows the store to be shared between the host and guest.)"
179
180 (format #t "mounting QEMU's SMB share `~a'...\n" share)
181 (let ((server "10.0.2.4"))
182 (mount (string-append "//" server share) mount-point "cifs" 0
183 (string->pointer "guest,sec=none"))))
184
4919d684
LC
185(define (mount-qemu-9p source mount-point)
186 "Mount QEMU's 9p file system from SOURCE at MOUNT-POINT.
187
188This uses the 'virtio' transport, which requires the various virtio Linux
189modules to be loaded."
190
191 (format #t "mounting QEMU's 9p share '~a'...\n" source)
192 (let ((server "10.0.2.4"))
193 (mount source mount-point "9p" 0
194 (string->pointer "trans=virtio"))))
195
89bf140b
LC
196(define (bind-mount source target)
197 "Bind-mount SOURCE at TARGET."
198 (define MS_BIND 4096) ; from libc's <sys/mount.h>
199
200 (mount source target "" MS_BIND))
201
88840f02
LC
202(define (load-linux-module* file)
203 "Load Linux module from FILE, the name of a `.ko' file."
204 (define (slurp module)
205 (call-with-input-file file get-bytevector-all))
206
207 (load-linux-module (slurp file)))
208
209(define (device-number major minor)
210 "Return the device number for the device with MAJOR and MINOR, for use as
211the last argument of `mknod'."
212 (+ (* major 256) minor))
213
d4254711
LC
214(define* (boot-system #:key
215 (linux-modules '())
216 qemu-guest-networking?
217 guile-modules-in-chroot?
1c96c1bb 218 volatile-root? unionfs
d4254711
LC
219 (mounts '()))
220 "This procedure is meant to be called from an initrd. Boot a system by
221first loading LINUX-MODULES, then setting up QEMU guest networking if
222QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS,
223and finally booting into the new root if any. The initrd supports kernel
224command-line options '--load', '--root', and '--repl'.
225
226MOUNTS must be a list of elements of the form:
227
228 (FILE-SYSTEM-TYPE SOURCE TARGET)
229
230When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
44ddf33e
LC
231the new root.
232
233When VOLATILE-ROOT? is true, the root file system is writable but any changes
234to it are lost."
d4254711
LC
235 (define (resolve file)
236 ;; If FILE is a symlink to an absolute file name, resolve it as if we were
237 ;; under /root.
238 (let ((st (lstat file)))
239 (if (eq? 'symlink (stat:type st))
240 (let ((target (readlink file)))
241 (resolve (string-append "/root" target)))
242 file)))
243
44ddf33e
LC
244 (define MS_RDONLY 1)
245
d4254711
LC
246 (display "Welcome, this is GNU's early boot Guile.\n")
247 (display "Use '--repl' for an initrd REPL.\n\n")
248
249 (mount-essential-file-systems)
250 (let* ((args (linux-command-line))
251 (option (lambda (opt)
252 (let ((opt (string-append opt "=")))
253 (and=> (find (cut string-prefix? opt <>)
254 args)
255 (lambda (arg)
256 (substring arg (+ 1 (string-index arg #\=))))))))
257 (to-load (option "--load"))
258 (root (option "--root")))
259
260 (when (member "--repl" args)
261 (start-repl))
262
263 (display "loading kernel modules...\n")
264 (for-each (compose load-linux-module*
265 (cut string-append "/modules/" <>))
266 linux-modules)
267
268 (when qemu-guest-networking?
269 (unless (configure-qemu-networking)
270 (display "network interface is DOWN\n")))
271
272 ;; Make /dev nodes.
273 (make-essential-device-nodes)
274
275 ;; Prepare the real root file system under /root.
276 (unless (file-exists? "/root")
277 (mkdir "/root"))
278 (if root
83b9e6a1
LC
279 (catch #t
280 (lambda ()
44ddf33e
LC
281 (if volatile-root?
282 (begin
44ddf33e
LC
283 (mkdir-p "/real-root")
284 (mount root "/real-root" "ext3" MS_RDONLY)
1c96c1bb
LC
285 (mkdir-p "/rw-root")
286 (mount "none" "/rw-root" "tmpfs")
287
288 ;; We want read-write /dev nodes.
289 (make-essential-device-nodes #:root "/rw-root")
290
291 ;; Make /root a union of the tmpfs and the actual root.
292 (unless (zero? (system* unionfs "-o"
d8a7a5bf 293 "cow,allow_other,use_ino,suid,dev"
1c96c1bb
LC
294 "/rw-root=RW:/real-root=RO"
295 "/root"))
296 (error "unionfs failed")))
44ddf33e 297 (mount root "/root" "ext3")))
83b9e6a1
LC
298 (lambda args
299 (format (current-error-port) "exception while mounting '~a': ~s~%"
300 root args)
301 (start-repl)))
d4254711 302 (mount "none" "/root" "tmpfs"))
44ddf33e 303
d4254711
LC
304 (mount-essential-file-systems #:root "/root")
305
306 (unless (file-exists? "/root/dev")
307 (mkdir "/root/dev")
308 (make-essential-device-nodes #:root "/root"))
309
310 ;; Mount the specified file systems.
311 (for-each (match-lambda
312 (('cifs source target)
313 (let ((target (string-append "/root/" target)))
314 (mkdir-p target)
315 (mount-qemu-smb-share source target)))
4919d684
LC
316 (('9p source target)
317 (let ((target (string-append "/root/" target)))
318 (mkdir-p target)
319 (mount-qemu-9p source target))))
d4254711
LC
320 mounts)
321
322 (when guile-modules-in-chroot?
323 ;; Copy the directories that contain .scm and .go files so that the
324 ;; child process in the chroot can load modules (we would bind-mount
325 ;; them but for some reason that fails with EINVAL -- XXX).
326 (mkdir-p "/root/share")
327 (mkdir-p "/root/lib")
328 (mount "none" "/root/share" "tmpfs")
329 (mount "none" "/root/lib" "tmpfs")
330 (copy-recursively "/share" "/root/share"
331 #:log (%make-void-port "w"))
332 (copy-recursively "/lib" "/root/lib"
333 #:log (%make-void-port "w")))
334
335 (if to-load
336 (begin
337 (format #t "loading '~a'...\n" to-load)
26fc862a 338 (chdir "/root")
d4254711 339 (chroot "/root")
c865a878
LC
340
341 ;; Obviously this has to be done each time we boot. Do it from here
342 ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3)
343 ;; expects (and thus openpty(3) and its users, such as xterm.)
344 (mount "none" "/dev/pts" "devpts")
345
d4254711
LC
346 ;; TODO: Remove /lib, /share, and /loader.go.
347 (catch #t
348 (lambda ()
349 (primitive-load to-load))
350 (lambda args
351 (format (current-error-port) "'~a' raised an exception: ~s~%"
352 to-load args)
353 (start-repl)))
354 (format (current-error-port)
355 "boot program '~a' terminated, rebooting~%"
356 to-load)
357 (sleep 2)
358 (reboot))
359 (begin
360 (display "no boot file passed via '--load'\n")
361 (display "entering a warm and cozy REPL\n")
362 (start-repl)))))
363
88840f02 364;;; linux-initrd.scm ends here