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.

5 files changed, 47 insertions, 97 deletions

diff --git a/gnu-system.am b/gnu-system.am
index 473346c6ee..1f7327e865 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -128,7 +128,6 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/libunwind.scm			\
   gnu/packages/lightning.scm			\
   gnu/packages/linux.scm			\
-  gnu/packages/linux-initrd.scm			\
   gnu/packages/lout.scm				\
   gnu/packages/lsh.scm				\
   gnu/packages/lsof.scm				\
@@ -221,6 +220,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/system/dmd.scm				\
   gnu/system/grub.scm				\
   gnu/system/linux.scm				\
+  gnu/system/linux-initrd.scm			\
   gnu/system/shadow.scm				\
   gnu/system/vm.scm
 
diff --git a/gnu/system.scm b/gnu/system.scm
index 6fd753f8fd..5fb4a7483e 100644
--- a/gnu/system.scm
+++ b/gnu/system.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.
 ;;;
@@ -22,7 +22,6 @@
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix derivations)
-  #:use-module (gnu packages linux-initrd)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages admin)
@@ -31,6 +30,7 @@
   #:use-module (gnu system grub)
   #:use-module (gnu system shadow)
   #:use-module (gnu system linux)
+  #:use-module (gnu system linux-initrd)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -58,8 +58,8 @@
               (default grub))
   (bootloader-entries operating-system-bootloader-entries ; list
                       (default '()))
-  (initrd operating-system-initrd
-          (default gnu-system-initrd))
+  (initrd operating-system-initrd                 ; monadic derivation
+          (default (gnu-system-initrd)))
 
   (host-name operating-system-host-name)          ; string
 
@@ -321,8 +321,9 @@ alias ll='ls -l'
                                      "--config" ,dmd-conf))))
        (kernel  ->  (operating-system-kernel os))
        (kernel-dir  (package-file kernel))
-       (initrd  ->  (operating-system-initrd os))
-       (initrd-file (package-file initrd))
+       (initrd      (operating-system-initrd os))
+       (initrd-file -> (string-append (derivation->output-path initrd)
+                                      "/initrd"))
        (entries ->  (list (menu-entry
                            (label (string-append
                                    "GNU system with "
@@ -331,7 +332,7 @@ alias ll='ls -l'
                            (linux kernel)
                            (linux-arguments `("--root=/dev/vda1"
                                               ,(string-append "--load=" boot)))
-                           (initrd initrd))))
+                           (initrd initrd-file))))
        (grub.cfg (grub-configuration-file entries))
        (extras   (links (delete-duplicates
                          (append (append-map service-inputs services)
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/packages/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 5495e16e30..a28b913c3e 100644
--- a/gnu/packages/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -16,22 +16,18 @@
 ;;; 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)
+(define-module (gnu system linux-initrd)
+  #:use-module (guix monads)
   #:use-module (guix utils)
-  #:use-module (guix licenses)
-  #:use-module (guix build-system)
-  #:use-module ((guix derivations)
-                #:select (imported-modules compiled-modules %guile-for-build))
-  #:use-module (gnu packages)
   #: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))
-  #:use-module (guix packages)
-  #:use-module (guix download)
-  #:use-module (guix build-system trivial))
+  #:export (expression->initrd
+            qemu-initrd
+            gnu-system-initrd))
 
 
 ;;; Commentary:
@@ -42,49 +38,6 @@
 ;;; Code:
 
 
-(define-syntax-rule (raw-build-system (store system name inputs) body ...)
-  "Lift BODY to a package build system."
-  ;; TODO: Generalize.
-  (build-system
-   (name "raw")
-   (description "Raw build system")
-   (build (lambda* (store name source inputs #:key system #:allow-other-keys)
-            (parameterize ((%guile-for-build (package-derivation store
-                                                                 guile-2.0)))
-              body ...)))))
-
-(define (module-package modules)
-  "Return a package that contains all of MODULES, a list of Guile module
-names."
-  (package
-    (name "guile-modules")
-    (version "0")
-    (source #f)
-    (build-system (raw-build-system (store system name inputs)
-                    (imported-modules store modules
-                                      #:name name
-                                      #:system system)))
-    (synopsis "Set of Guile modules")
-    (description synopsis)
-    (license gpl3+)
-    (home-page "http://www.gnu.org/software/guix/")))
-
-(define (compiled-module-package modules)
-  "Return a package that contains the .go files corresponding to MODULES, a
-list of Guile module names."
-  (package
-    (name "guile-compiled-modules")
-    (version "0")
-    (source #f)
-    (build-system (raw-build-system (store system name inputs)
-                    (compiled-modules store modules
-                                      #:name name
-                                      #:system system)))
-    (synopsis "Set of compiled Guile modules")
-    (description synopsis)
-    (license gpl3+)
-    (home-page "http://www.gnu.org/software/guix/")))
-
 (define* (expression->initrd exp
                              #:key
                              (guile %guile-static-stripped)
@@ -212,29 +165,25 @@ list of Guile module names to be embedded in the initrd."
                     (and (zero? (system* gzip "--best" "initrd"))
                          (rename-file "initrd.gz" "initrd")))))))))
 
-  (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)
-              ("modules" ,(module-package modules))
-              ("modules/compiled" ,(compiled-module-package modules))
-              ,@(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
+  (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)
@@ -339,8 +288,8 @@ the Linux kernel.")
    #:linux linux-libre
    #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))
 
-(define-public gnu-system-initrd
-  ;; Initrd for the GNU system itself, with nothing QEMU-specific.
+(define (gnu-system-initrd)
+  "Initrd for the GNU system itself, with nothing QEMU-specific."
   (expression->initrd
    '(begin
       (use-modules (srfi srfi-1)
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)