gnu: Lower initrd makers from packages to monadic procedures.

* gnu/packages/linux-initrd.scm: Remove.
* gnu/system/linux-initrd.scm: New file.
* gnu-system.am (GNU_SYSTEM_MODULES): Adjust accordingly.
* gnu/system.scm (<operating-system>): Change default 'initrd' value
  to (gnu-system-initrd).
  (operating-system-derivation): Bind 'operating-system-initrd'.  Pass
  'menu-entry' an initrd file name instead of a package.
* gnu/system/grub.scm (grub-configuration-file): Expect 'initrd' to be
  file name.

3 files changed, 372 insertions, 12 deletions

diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 86fa9b504d..5dc0b85ff2 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,7 +41,7 @@
   (linux           menu-entry-linux)
   (linux-arguments menu-entry-linux-arguments
                    (default '()))
-  (initrd          menu-entry-initrd))
+  (initrd          menu-entry-initrd))            ; file name of the initrd
 
 (define* (grub-configuration-file entries
                                   #:key (default-entry 1) (timeout 5)
@@ -66,10 +66,7 @@ search.file ~a~%"
     (match-lambda
      (($ <menu-entry> label linux arguments initrd)
       (mlet %store-monad ((linux  (package-file linux "bzImage"
-                                                #:system system))
-                          (initrd (package-file initrd "initrd"
                                                 #:system system)))
-        ;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
         (return (format #f "menuentry ~s {
   linux ~a ~a
   initrd ~a
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
new file mode 100644
index 0000000000..a28b913c3e
--- /dev/null
+++ b/gnu/system/linux-initrd.scm
@@ -0,0 +1,360 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 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 system linux-initrd)
+  #:use-module (guix monads)
+  #:use-module (guix utils)
+  #:use-module (gnu packages cpio)
+  #:use-module (gnu packages compression)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages guile)
+  #:use-module ((gnu packages make-bootstrap)
+                #:select (%guile-static-stripped))
+  #:export (expression->initrd
+            qemu-initrd
+            gnu-system-initrd))
+
+
+;;; 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))
+                             (modules '())
+                             (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.  MODULES is a
+list of Guile module names to be embedded in the initrd."
+
+  ;; 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"))
+             (modules (assoc-ref %build-inputs "modules"))
+             (gos     (assoc-ref %build-inputs "modules/compiled"))
+             (scm-dir (string-append "share/guile/" (effective-version)))
+             (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a"
+                              (effective-version)
+                              (if (eq? (native-endianness) (endianness little))
+                                  "LE"
+                                  "BE")
+                              (sizeof '*)
+                              (effective-version)))
+             (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)
+
+           ;; Copy Guile modules.
+           (chmod scm-dir #o777)
+           (copy-recursively modules scm-dir
+                             #:follow-symlinks? #t)
+           (copy-recursively gos (string-append "lib/guile/"
+                                                (effective-version) "/ccache")
+                             #:follow-symlinks? #t)
+
+           ;; Compile `init'.
+           (mkdir-p go-dir)
+           (set! %load-path (cons modules %load-path))
+           (set! %load-compiled-path (cons gos %load-compiled-path))
+           (compile-file "init"
+                         #:opts %auto-compilation-options
+                         #:output-file (string-append go-dir "/init.go"))
+
+           ;; Copy Linux modules.
+           (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")))))))))
+
+  (mlet* %store-monad
+      ((source   (imported-modules modules))
+       (compiled (compiled-modules modules))
+       (inputs   (lower-inputs
+                  `(("guile" ,guile)
+                    ("cpio" ,cpio)
+                    ("gzip" ,gzip)
+                    ("modules" ,source)
+                    ("modules/compiled" ,compiled)
+                    ,@(if linux
+                          `(("linux" ,linux))
+                          '())))))
+   (derivation-expression name builder
+                          #:modules '((guix build utils))
+                          #:inputs inputs)))
+
+(define (qemu-initrd)
+  "Return a monadic derivation that builds an initrd for use in a QEMU guest
+where the store is shared with the host."
+  (expression->initrd
+   '(begin
+      (use-modules (srfi srfi-1)
+                   (srfi srfi-26)
+                   (ice-9 match)
+                   ((system base compile) #:select (compile-file))
+                   (guix build utils)
+                   (guix build linux-initrd))
+
+      (display "Welcome, this is GNU's early boot Guile.\n")
+      (display "Use '--repl' for an initrd REPL.\n\n")
+
+      (mount-essential-file-systems)
+      (let* ((args    (linux-command-line))
+             (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)))
+
+        (display "loading CIFS and companion modules...\n")
+        (for-each (compose load-linux-module*
+                           (cut string-append "/modules/" <>))
+                  (list "md4.ko" "ecb.ko" "cifs.ko"))
+
+        (unless (configure-qemu-networking)
+          (display "network interface is DOWN\n"))
+
+        ;; Make /dev nodes.
+        (make-essential-device-nodes)
+
+        ;; Prepare the real root file system under /root.
+        (unless (file-exists? "/root")
+          (mkdir "/root"))
+        (if root
+            (mount root "/root" "ext3")
+            (mount "none" "/root" "tmpfs"))
+        (mount-essential-file-systems #:root "/root")
+
+        (mkdir-p "/root/xchg")
+        (mkdir-p "/root/nix/store")
+
+        (unless (file-exists? "/root/dev")
+          (mkdir "/root/dev")
+          (make-essential-device-nodes #:root "/root"))
+
+        ;; Mount the host's store and exchange directory.
+        (mount-qemu-smb-share "/store" "/root/nix/store")
+        (mount-qemu-smb-share "/xchg" "/root/xchg")
+
+        ;; Copy the directories that contain .scm and .go files so that the
+        ;; child process in the chroot can load modules (we would bind-mount
+        ;; them but for some reason that fails with EINVAL -- XXX).
+        (mkdir-p "/root/share")
+        (mkdir-p "/root/lib")
+        (mount "none" "/root/share" "tmpfs")
+        (mount "none" "/root/lib" "tmpfs")
+        (copy-recursively "/share" "/root/share"
+                          #:log (%make-void-port "w"))
+        (copy-recursively "/lib" "/root/lib"
+                          #:log (%make-void-port "w"))
+
+
+        (if to-load
+            (letrec ((resolve
+                      (lambda (file)
+                        ;; If FILE is a symlink to an absolute file name,
+                        ;; resolve it as if we were under /root.
+                        (let ((st (lstat file)))
+                          (if (eq? 'symlink (stat:type st))
+                              (let ((target (readlink file)))
+                                (resolve (string-append "/root" target)))
+                              file)))))
+              (format #t "loading boot file '~a'...\n" to-load)
+              (compile-file (resolve (string-append "/root/" to-load))
+                            #:output-file "/root/loader.go"
+                            #:opts %auto-compilation-options)
+              (match (primitive-fork)
+                (0
+                 (chroot "/root")
+                 (load-compiled "/loader.go")
+
+                 ;; TODO: Remove /lib, /share, and /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"
+   #:modules '((guix build utils)
+               (guix build linux-initrd))
+   #:linux linux-libre
+   #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))
+
+(define (gnu-system-initrd)
+  "Initrd for the GNU system itself, with nothing QEMU-specific."
+  (expression->initrd
+   '(begin
+      (use-modules (srfi srfi-1)
+                   (srfi srfi-26)
+                   (ice-9 match)
+                   (guix build utils)
+                   (guix build linux-initrd))
+
+      (display "Welcome, this is GNU's early boot Guile.\n")
+      (display "Use '--repl' for an initrd REPL.\n\n")
+
+      (mount-essential-file-systems)
+      (let* ((args    (linux-command-line))
+             (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)))
+
+        ;; Make /dev nodes.
+        (make-essential-device-nodes)
+
+        ;; Prepare the real root file system under /root.
+        (mkdir-p "/root")
+        (if root
+            ;; Assume ROOT has a usable /dev tree.
+            (mount root "/root" "ext3")
+            (begin
+              (mount "none" "/root" "tmpfs")
+              (make-essential-device-nodes #:root "/root")))
+
+        (mount-essential-file-systems #:root "/root")
+
+        (mkdir-p "/root/tmp")
+        (mount "none" "/root/tmp" "tmpfs")
+
+        ;; XXX: We don't copy our fellow Guile modules to /root (see
+        ;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can
+        ;; happen if it throws, to display the exception!), then we're
+        ;; screwed.  Hopefully TO-LOAD is a simple expression that just does
+        ;; '(execlp ...)'.
+
+        (if to-load
+            (begin
+              (format #t "loading '~a'...\n" to-load)
+              (chroot "/root")
+              (primitive-load to-load)
+              (format (current-error-port)
+                      "boot program '~a' terminated, rebooting~%"
+                      to-load)
+              (sleep 2)
+              (reboot))
+            (begin
+              (display "no init file passed via '--load'\n")
+              (display "entering a warm and cozy REPL\n")
+              ((@ (system repl repl) start-repl))))))
+   #:name "qemu-system-initrd"
+   #:modules '((guix build linux-initrd)
+               (guix build utils))
+   #:linux linux-libre))
+
+;;; linux-initrd.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index e75c09d859..fa93654144 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,7 +35,6 @@
   #:use-module (gnu packages zile)
   #:use-module (gnu packages grub)
   #:use-module (gnu packages linux)
-  #:use-module (gnu packages linux-initrd)
   #:use-module (gnu packages package-management)
   #:use-module ((gnu packages make-bootstrap)
                 #:select (%guile-static-stripped))
@@ -43,6 +42,7 @@
 
   #:use-module (gnu system shadow)
   #:use-module (gnu system linux)
+  #:use-module (gnu system linux-initrd)
   #:use-module (gnu system grub)
   #:use-module (gnu system dmd)
   #:use-module (gnu system)
@@ -67,7 +67,7 @@
                                              (system (%current-system))
                                              (inputs '())
                                              (linux linux-libre)
-                                             (initrd qemu-initrd)
+                                             initrd
                                              (qemu qemu/smb-shares)
                                              (env-vars '())
                                              (modules '())
@@ -78,10 +78,10 @@
                                              (references-graphs #f)
                                              (disk-image-size
                                               (* 100 (expt 2 20))))
-  "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD.  In the
-virtual machine, EXP has access to all of INPUTS from the store; it should put
-its output files in the `/xchg' directory, which is copied to the derivation's
-output when the VM terminates.
+  "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
+derivation).  In the virtual machine, EXP has access to all of INPUTS from the
+store; it should put its output files in the `/xchg' directory, which is
+copied to the derivation's output when the VM terminates.
 
 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of
 DISK-IMAGE-SIZE bytes and return it.
@@ -178,6 +178,9 @@ made available under the /xchg CIFS share."
        (user-builder (text-file "builder-in-linux-vm"
                                 (object->string exp*)))
        (coreutils -> (car (assoc-ref %final-inputs "coreutils")))
+       (initrd       (if initrd
+                         (return initrd)
+                         (qemu-initrd)))          ; default initrd
        (inputs       (lower-inputs `(("qemu" ,qemu)
                                      ("linux" ,linux)
                                      ("initrd" ,initrd)