guix/build/linux-initrd.scm

   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 (guix build linux-initrd)
  20   #:use-module (rnrs io ports)
  21   #:use-module (system foreign)
  22   #:export (mount-essential-file-systems
  23             linux-command-line
  24             make-essential-device-nodes
  25             configure-qemu-networking
  26             mount-qemu-smb-share
  27             bind-mount
  28             load-linux-module*
  29             device-number))
  30
  31 ;;; Commentary:
  32 ;;;
  33 ;;; Utility procedures useful in a Linux initial RAM disk (initrd).  Note that
  34 ;;; many of these use procedures not yet available in vanilla Guile (`mount',
  35 ;;; `load-linux-module', etc.); these are provided by a Guile patch used in
  36 ;;; the GNU distribution.
  37 ;;;
  38 ;;; Code:
  39
  40 (define* (mount-essential-file-systems #:key (root "/"))
  41   "Mount /proc and /sys under ROOT."
  42   (define (scope dir)
  43     (string-append root
  44                    (if (string-suffix? "/" root)
  45                        ""
  46                        "/")
  47                    dir))
  48
  49   (unless (file-exists? (scope "proc"))
  50     (mkdir (scope "proc")))
  51   (mount "none" (scope "proc") "proc")
  52
  53   (unless (file-exists? (scope "sys"))
  54     (mkdir (scope "sys")))
  55   (mount "none" (scope "sys") "sysfs"))
  56
  57 (define (linux-command-line)
  58   "Return the Linux kernel command line as a list of strings."
  59   (string-tokenize
  60    (call-with-input-file "/proc/cmdline"
  61      get-string-all)))
  62
  63 (define* (make-essential-device-nodes #:key (root "/"))
  64   "Make essential device nodes under ROOT/dev."
  65   ;; The hand-made udev!
  66
  67   (define (scope dir)
  68     (string-append root
  69                    (if (string-suffix? "/" root)
  70                        ""
  71                        "/")
  72                    dir))
  73
  74   (unless (file-exists? (scope "dev"))
  75     (mkdir (scope "dev")))
  76
  77   ;; Make the device nodes for QEMU's hard disk and partitions.
  78   (mknod (scope "dev/vda") 'block-special #o644 (device-number 8 0))
  79   (mknod (scope "dev/vda1") 'block-special #o644 (device-number 8 1))
  80   (mknod (scope "dev/vda2") 'block-special #o644 (device-number 8 2))
  81
  82   ;; TTYs.
  83   (mknod (scope "dev/tty") 'char-special #o600
  84          (device-number 5 0))
  85   (let loop ((n 0))
  86     (and (< n 50)
  87          (let ((name (format #f "dev/tty~a" n)))
  88            (mknod (scope name) 'char-special #o600
  89                   (device-number 4 n))
  90            (loop (+ 1 n)))))
  91
  92   ;; Other useful nodes.
  93   (mknod (scope "dev/null") 'char-special #o666 (device-number 1 3))
  94   (mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5)))
  95
  96 (define %host-qemu-ipv4-address
  97   (inet-pton AF_INET "10.0.2.10"))
  98
  99 (define* (configure-qemu-networking #:optional (interface "eth0"))
 100   "Setup the INTERFACE network interface and /etc/resolv.conf according to
 101 QEMU's default networking settings (see net/slirp.c in QEMU for default
 102 networking values.)  Return #t if INTERFACE is up, #f otherwise."
 103   (display "configuring QEMU networking...\n")
 104   (let* ((sock    (socket AF_INET SOCK_STREAM 0))
 105          (address (make-socket-address AF_INET %host-qemu-ipv4-address 0))
 106          (flags   (network-interface-flags sock interface)))
 107     (set-network-interface-address sock interface address)
 108     (set-network-interface-flags sock interface (logior flags IFF_UP))
 109
 110     (unless (file-exists? "/etc")
 111       (mkdir "/etc"))
 112     (call-with-output-file "/etc/resolv.conf"
 113       (lambda (p)
 114         (display "nameserver 10.0.2.3\n" p)))
 115
 116     (logand (network-interface-flags sock interface) IFF_UP)))
 117
 118 (define (mount-qemu-smb-share share mount-point)
 119   "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT.
 120
 121 Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our
 122 `qemu-with-multiple-smb-shares' package exports the /xchg and /store shares
 123  (the latter allows the store to be shared between the host and guest.)"
 124
 125   (format #t "mounting QEMU's SMB share `~a'...\n" share)
 126   (let ((server "10.0.2.4"))
 127     (mount (string-append "//" server share) mount-point "cifs" 0
 128            (string->pointer "guest,sec=none"))))
 129
 130 (define (bind-mount source target)
 131   "Bind-mount SOURCE at TARGET."
 132   (define MS_BIND 4096)                           ; from libc's <sys/mount.h>
 133
 134   (mount source target "" MS_BIND))
 135
 136 (define (load-linux-module* file)
 137   "Load Linux module from FILE, the name of a `.ko' file."
 138   (define (slurp module)
 139     (call-with-input-file file get-bytevector-all))
 140
 141   (load-linux-module (slurp file)))
 142
 143 (define (device-number major minor)
 144   "Return the device number for the device with MAJOR and MINOR, for use as
 145 the last argument of `mknod'."
 146   (+ (* major 256) minor))
 147
 148 ;;; linux-initrd.scm ends here