gnu: Add support for Guile in Linux initrd.

* gnu/packages/linux-initrd.scm: New file.

Makefile.am

@@ -107,6 +107,7 @@ MODULES =					\
   gnu/packages/libusb.scm			\
   gnu/packages/libunwind.scm			\
   gnu/packages/linux.scm			\
+  gnu/packages/linux-initrd.scm			\
   gnu/packages/lout.scm				\
   gnu/packages/lsh.scm				\
   gnu/packages/m4.scm				\

gnu/packages/linux-initrd.scm

@@ -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