gnu/packages/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 (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